はじめに

本記事は三重大学計算研 Advent Calendar 201916日目です。
少し前までAtCoderに参加していましたが、最近やる気が出なかったのでやる気を出すためかつストレスフリーになるように自動提出やテストケースのチェック等をできるプログラムを書きました。ソースコードはhttps://github.com/flow6852/atsubmit に置いてあります。
本記事はその時に使った様々なモジュール内で定義された関数の使い方や設計のメモを残すこと、筆者が初めて知ったことを書いておくことが目的です。

おことわり

本記事はHaskellを使ってAtCoderのパフォーマンスを向上させる内容ではなくコンテストに快適に参加するためのツールを作成したという内容です。
汚い実装(モナドの恩恵を感じられない...)です
参考文献が結構多いので必要な部分で適宜参考文献を載せていき、最後にも参考文献を書きます。

追記

もっとHaskellでAtCoderに参加したいにGADTsを用いた実装があります.

開発環境

OS Linux
ディストロ ArchLinux
言語 Haskell
ビルドツール stack

その他に使用したツール

docker
chromium

操作手順と本プログラムの要件

参加手順とやりたいこと

ユーザは(おそらく)次の手順でコンテストに参加します。

AtCoderにログインする
コンテストへの参加登録をする
コンテスト参加まで待機する(鼓舞、睡眠、エディタを開くなど)
コンテスト開始時にタスクページにアクセスする
問題を解く
テストケースで正しいか試す
提出する
結果をみて、ACなら次の問題へ、そうでなければもう一度解く

そのため本プログラムにはエディタから

ログイン機能(セッション管理)
問題のページの取得
テストケースの出力
テストケースの実行と結果が正しいかどうかの判定
提出
結果の閲覧
ログアウト機能

が操作できるとうれしいです。

設計

セッションを管理して各機能を実行するサーバとそれを操作するクライアントがあると、各エディタのプラグインに発展できるのでサーバとクライアント(の例？)に分けてそれぞれ設計しています。

一つのコンピュータでサーバとクライアントの間の通信をする方法として

ファイル
UnixDomainSocket

があげられます。今回はUnixDomainSocketを用いて実装しました。(初めて知りました...)

サーバ

先に挙げた機能を実装したいので

サーバの各機能への命名
サーバの受け取るデータの形式

を決定します。

各機能への命名

それぞれ

login
get
show
test
submit
result
stop

としました。

サーバの受け取るデータの形式

まずは各機能の実装に必要かつクライアントからしか得られない情報を決めました。これはデータをJSONとしてやりとりするためです。その情報は

サブコマンド(例:submit)
コンテスト名(例:abc150)
問題名(例:a)
ファイル(例:submit.hs)
クライアントの実行時のディレクトリ(例:/home)

です。

あとは各機能について実装しました。

クライアント

クライアント側の実行コマンドは次のものを想定します。

$ atsubmit # サーバの起動
$ atsubmit get abc150_a # abc150のa問題の情報を取得する
$ atsubmit show abc150_a # abc150のa問題の保存したhtmlファイルのパス、入出力のテストケースの表示
$ atsubmit show # 今までにgetした問題のリスト
$ atsubmit test abc150_a submit.hs # submit.hsがabc150_aで正しいかをテストする
$ atsubmit submit abc150_a submit.hs # submit.hsをabc150_aとして提出する
$ atsubmit result abc150 # abc150の全結果を出力する
$ atsubmit stop # サーバの停止

引数を先に挙げた形式に変えて実装しました。

実装

代数データ型

定めた型シノニムや代数データ型は次のとおりです。

src/Lib.hs

type AtFunc = Contest -> AtSubmit -> IO (T.Text, Contest)

data Question = Question { qurl :: T.Text -- question page's url
                         , qio :: V.Vector (T.Text, T.Text) -- input, output
                         , htmlpath :: System.IO.FilePath -- raw html file path
                         } deriving (Show, Eq)

data Contest = Contest { questions :: V.Vector Question 
                       , cookie :: [BSC.ByteString]
                       , csrf_token :: T.Text
                       } deriving (Show, Eq)

data AtSubmit = AtSubmit { rcom :: T.Text -- rawcommand
                         , subcmd :: T.Text
                         , cname :: Maybe T.Text -- contest name (ex abc120 
                         , qname :: Maybe T.Text -- question name (ex a
                         , file :: Maybe T.Text
                         , userdir :: T.Text
                         } deriving (Show, Eq)

Contestはコンテストの情報をサーバが保持しておくためのデータ型です。
AtSubmitはサーバ,クライアント間でやり取りするときのJSONの各キーです。

aeson

JSONをデータ型にしたりテキストベースにする時にaesonがよく使われるらしいです。

src/Lib.hs

instance DA.FromJSON AtSubmit where
 parseJSON (DA.Object v) = AtSubmit <$> (v DA..: "rcom")
                                    <*> (v DA..: "subcmd")
                                    <*> (v DA..:? "cname")
                                    <*> (v DA..:? "qname")
                                    <*> (v DA..:? "file")
                                    <*> (v DA..: "userdir")

instance DA.ToJSON AtSubmit where
 toJSON (AtSubmit rc sc cn qn f u) = DA.object [ "rcom" DA..= rc
                                               , "subcmd" DA..= sc
                                               , "cname" DA..= cn
                                               , "qname" DA..= qn
                                               , "file" DA..= f
                                               , "userdir" DA..= u]

FromJSONとToJSON型クラスのインスタンスとして実装すればあとは

encode :: ToJSON a => a -> Data.ByteString.Lazy.Internal.ByteString
decode :: FromJSON a => Data.ByteString.Lazy.Internal.ByteString -> Maybe a

を使ってJSONとテキストを変更できます。ファイル以外はMaybe型ではなくリストとして実装したほうが複数のコンテストの情報を一度に取れるのでそちらのほうがいいかもしれません。

参考文献

UnixDomainSocket

Network.Socketを使います

src/UnixDomainSocket.hs

module UnixDomainSocket where

import Lib

import Control.Concurrent
import Data.List
import Network.Socket
import qualified Network.Socket.ByteString as NSBS
import Control.Monad
import System.Directory
import qualified Control.Exception as E
import qualified Data.Vector as V

-- server part
runServer :: Contest -> FilePath -> (Socket -> Contest -> IO (Bool, Contest)) -> IO()
runServer contest path server = withSocketsDo $ E.bracket (open path) close (loop contest)
 where
  loop :: Contest -> Socket -> IO()
  loop contest s = do
   (conn, peer) <- accept s
   (endCheck, next) <- server conn contest
   close conn
   if endCheck then return () else loop next s
  open :: FilePath -> IO Socket
  open path = do
   sock <- socket AF_UNIX Stream 0
   rmFile path
   ready sock
  ready s = do  
   bind s (SockAddrUnix path)
   listen s 1
   return s -- ready
  rmFile :: FilePath -> IO()
  rmFile path = doesFileExist path >>= \x -> when x (removeFile path)

-- client part
sendServer :: FilePath -> (Socket -> IO()) -> IO()
sendServer path client = withSocketsDo $ E.bracket (open path) close client
 where
  open :: FilePath -> IO Socket
  open path = do
   s <- socket AF_UNIX Stream 0
   connect s (SockAddrUnix path)
   return s

(複数のコンピュータのソケット通信を実装したことはないですが)通常のソケット通信同様の実装です。AF_UNIXでソケット通信をUnixDomainSocketに決めています。runServerはserver関数をサーバとして走らせておく関数でserverの返り値の第一要素の真偽に応じてサーバを停止するかどうかを決定します。(killコマンドを使っても良いがログアウトしてすぐにプロセスが終了したほうが楽なため)
sendServerも同様です。
withSocketsDo :: IO a -> IO aは(よくわかっていませんが)今は必要ないけど古いバージョンのWindowsのために書いておいてねとhackage(stackage)にあるので書いておきます(UnixDomainSocketこのプログラムがWindowsで動く想定を全くしていないので意味が...)
bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO cはIO aをしてからa -> IO cをして最後にa -> IO bを実行する関数です。Control.Exceptionをimportしておく必要があります。

参考文献

サーバの実装

UnixDomainSocketに出てきたserver :: Socket -> Contest -> IO (Bool, Contest)を実装ます。

src/AtCoderLib.hs

server :: Socket -> Contest -> IO (Bool, Contest)
server sock contests = do
 json <- fromStrict <$> NSBS.recv sock 1024 
 case DA.decode json of
  Nothing -> NSBS.send sock ((encodeUtf8.T.pack) "parsing error")  >> return (False, contests)
  Just x  -> do
   let (func, retb) =  case (T.unpack.subcmd) x of
                            "stop"   -> (atLogout, True)
                            "get"    -> (atGetPage, False)
                            "show"   -> (atShowPage, False)
                            "submit" -> (atSubmit, False)
                            "test"   -> (atTest, False)
                            "login"  -> (atLogin, False)
                            "result" -> (atResult, False)
                            "help"   -> (atHelp, False)
                            _        -> (notDo, False)
   (resStr, retc) <- func contests x
                     `catch` (\e -> return ((T.pack.displayException) (e :: SomeException), contests))
   NSBS.send sock $ toStrict.DA.encode $ x { restext = Just resStr }
   return (retb, retc)
    where
     notDo :: AtFunc
     notDo c m = return (T.empty, c)

Network.Socket.ByteStringにあるrecv :: Socket -> Int -> IO Data.ByteString.Internal.ByteStringでjsonを受け取った値に応じてそれぞれ実行したい関数を決めて実行する(例外は握りつぶす)。最後に結果のjsonをテキストベースに変換してNetwork.Socket.ByteStringにあるsend :: Socket -> Data.ByteString.Internal.ByteString -> IO Intを用いてクライアントに送ります。

参考文献

各関数の実装


getAPIkeys :: [String] -> IO [String]
getAPIkeys [] = return []
getAPIkeys (m:messages) = do
 Prelude.putStr m 
 hFlush System.IO.stdout
 api <- Prelude.getLine 
 Prelude.putChar '\n'
 getAPIkeys messages >>= (\res -> return (api:res))

getAtKeys :: IO [String]
getAtKeys = do
 hSetEcho System.IO.stdin False
 System.IO.putStrLn "============== atcoder username and password ==============="
 apis <- getAPIkeys ["username : ", "password : "]
 hSetEcho System.IO.stdin True
 return apis

getRequestWrapper :: T.Text -> [BSC.ByteString] -> IO (Response BSL.ByteString)
getRequestWrapper url cke = do
 req <- if cke == [] then parseRequest (T.unpack url)
        else setRequestHeader hCookie cke <$> parseRequest (T.unpack url)
 mng <- newManager tlsManagerSettings
 Network.HTTP.Conduit.httpLbs req mng

postRequestWrapper :: T.Text -> [BSC.ByteString] -> [(BSC.ByteString, T.Text)] -> IO (Response BSL.ByteString)
postRequestWrapper url cke body = do
 req <- setRequestHeader hCookie cke <$> parseRequest (T.unpack url)
 let postReq = urlEncodedBody (Prelude.map (\(x,y) -> (x, encodeUtf8 y)) body) req
 mng <- newManager tlsManagerSettings

getCookieAndCsrfToken :: T.Text -> T.Text -> IO Contest
getCookieAndCsrfToken un pw = do
 fstres <- getRequestWrapper "https://atcoder.jp/login" []
 let !csrf_tkn = (getCsrfToken.decodeUtf8.BSL.toStrict.getResponseBody) fstres
 let !fstcke = getResponseHeader hSetCookie fstres
 responce <- postRequestWrapper "https://atcoder.jp/login" fstcke [ ("username", un), ("password", pw), ("csrf_token", csrf_tkn)]
 return $ if getResponseStatus responce /= status200 then createContest V.empty [] ((T.pack.show.getResponseStatusCode) responce)
                                                     else createContest V.empty (getResponseHeader hSetCookie responce) csrf_tkn

ログインはユーザ側からはusernameとpasswordが必要で、AtCoderではcsrf対策にログインページにアクセスした時にcsrf_tokenを投げてそのcsrf_tokenとcookieを使ってセッション維持と認証を行っている(っぽい)ので最初にログインページにgetリクエストを投げてレスポンスにあるcsrf_tokenを拾ってログインページにusername,passwordと一緒に投げれば良いです。

問題の取得

src/AtCoderLib.hs

atGetPage :: AtFunc 
atGetPage contests msg = case qname msg of
 Nothing -> return ("command error.", contests)
 Just qm -> if V.elem qm (V.map (T.takeWhileEnd (/='/').qurl) (questions contests)) then return ("already get.", contests) else do
               quest <- getPageInfo msg contests
               return $ if quest == nullQuestion then ("not found.", contests) 
                        else ("get html, url and samples.", contests {questions = V.snoc (questions contests) quest})

src/Lib.hs


ajax="https://ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js" 

getPageInfo :: AtSubmit -> Contest -> IO Question
getPageInfo msg ud = case (cname msg, qname msg) of
 (Just cm, Just qm) -> let questurl = V.foldl1 T.append ["https://atcoder.jp/contests/", cm, "/tasks/", qm] in
  if V.elem questurl ((V.map qurl.questions) ud) then return nullQuestion else do
   res <- getRequestWrapper questurl (cookie ud)
   if getResponseStatus res /= status200 then return nullQuestion 
   else let fname = T.unpack (V.foldl1 T.append [userdir msg, "/", qm, ".html"]) in
    TIO.writeFile fname ((rewriteHtml.decodeUtf8.BSL.toStrict.getResponseBody) res) >> return (
    createQuestion questurl ((questionIO.fromDocument.parseLBS.getResponseBody) res) fname) 
 _ -> return nullQuestion
 where 
  questionIO :: Cursor -> V.Vector (T.Text, T.Text)
  questionIO cursor = do
   let cs = Prelude.map child $ cursor $// attributeIs "class" "col-sm-12" &// element "section" &// element "pre" 
   V.fromList.ioZip $ Prelude.map ((`T.append` "\n"). chnl).concatMap content $ Prelude.concat.Prelude.tail $ cs
  ioZip :: [T.Text] -> [(T.Text, T.Text)]
  ioZip (i:o:lists) 
   | T.null i || T.singleton '\n' == i ||  T.null o || T.singleton '\n' == o  = []
   | Prelude.null lists || (T.null.Prelude.head) lists                        = [(i, o)] 
   | otherwise                                                                = (i, o):ioZip lists
  chnl :: T.Text -> T.Text
  chnl = T.dropWhile (\x -> (x==' ')||(x=='\n')).T.dropWhileEnd (\x -> (x==' ')||(x=='\n')).T.replace (T.pack "\r\n") (T.pack "\n")
  rewriteHtml :: T.Text -> T.Text
  rewriteHtml = T.replace "/public/js/lib/jquery-1.9.1.min.js?v=202001250219" ajax.T.replace "//cdn" "https://cdn"

複数回同じものをサーバからもらってくるのは相手サーバへの負荷が大変なのでatGetPageでは一度取得したデータはプロセスがいきている限りは二度と取ってこないようにしています(強制化ようオプション作ってもいいかも)。また、問題が存在しなければgetPageInfoの返り値を空のQuestion,そうでなければ何か入っているQuestionを返します。

getPageInfoは指定された問題のテストケースと生のテストケースを取得することが目的です。テストケースはサーバが持っておき、生のhtmlはクライアントの実行したディレクトリに[問題id].htmlというファイルに保存されます。このファイルはそのままだとMathJaxがうまくいかないですが、AtCoderからではなくhttps://ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js から取得するように変更しておきます。(ローカルにダウンロードしたほうが良いかもしれません)

参考文献

テストケースの表示

src/AtCoderLib.hs


atShowPage :: AtFunc
atShowPage contests msg = case qname msg of
 Nothing -> return ((atAllShow.questions) contests, contests)
 Just qm -> do 
  let mquest = V.find ((== qm).T.takeWhileEnd (/='/').qurl) $ questions contests
  let showPage = case mquest of Nothing -> "not found"
                                Just a  -> T.append "htmlfile\n" $ T.append ((T.pack.htmlpath) a) $ V.foldl1 T.append $ V.map showMsg $ qio a
  return (showPage, contests)
   where
    showMsg :: (T.Text, T.Text) -> T.Text
    showMsg q = V.foldl1 T.append ["\ninput\n", fst q, "\noutput\n", snd q]

atAllShow :: V.Vector Question  -> T.Text
atAllShow q = if V.null q then T.empty else T.append ((T.takeWhileEnd (/='/').qurl.V.head) q) 
                                          $ T.append (T.singleton '\n') $ atAllShow.V.tail $ q

テスト

src/AtCoderLib.hs

atTest :: AtFunc
atTest contests msg = case (qname msg, file msg) of
 (Just qm, Just fm) -> do
  home <- getHomeDirectory
  TIO.readFile (T.unpack (T.append (userdir msg) (T.append (T.singleton '/') fm))) >>= TIO.writeFile (home ++ mainfile)
  let mquest = V.find ((== qm).T.takeWhileEnd (/='/').qurl) $ questions contests
  result <- case mquest of Nothing -> return "not found"
                           Just a  -> testLoop (qio a) home 1
  return (result, contests)
 _  -> return (T.pack "command error.", contests)
 where
  mainfile = "/.cache/atsubmit/src/source.txt"

src/Lib.hs

testLoop :: V.Vector (T.Text, T.Text) -> System.IO.FilePath -> Int -> IO T.Text
testLoop qs dir k = if V.null qs then return T.empty else do
 TIO.writeFile infile $ (fst.V.head) qs
 TIO.writeFile outfile $ (snd.V.head) qs
 ec <- shell dockershell empty
 outres <- TIO.readFile outfile
 comp <- TIO.readFile compfile
 let out = case ec of
                ExitFailure 1 -> T.append "CE\n" comp
                ExitFailure 2 -> "RE\n"
                ExitFailure _ -> "TLE\n"
                ExitSuccess   -> if outres == (snd.V.head) qs then "AC\n" 
                                 else V.foldl1 T.append ["WA\n", "=== result ===\n", outres, "=== sample ===\n", (snd.V.head) qs]
 next <- testLoop (V.tail qs) dir (k+1)
 return $ V.foldl1 T.append [msgCreate k, out, next]
  where
   msgCreate :: Int -> T.Text
   msgCreate n = T.append "case " $ T.append ((T.pack.show) n) ": "
   infile = dir ++ "/.cache/atsubmit/src/input.txt"
   outfile = dir ++ "/.cache/atsubmit/src/outres.txt"
   compfile = dir ++ "/.cache/atsubmit/src/comp.txt"

docker/docker_judge.hs

#!/bin/env bash

dir=~/.cache/atsubmit

main=Main.hs
src=${dir}/src/source.txt
input=${dir}/src/input.txt
output=${dir}/src/output.txt
out=${dir}/src/outres.txt
comp=${dir}/src/comp.txt
timer=2

img=atjudge_hs

# dockerの操作
t=$(date +%Y%m%d%H%M%S)
docker create --name ${t} --pids-limit 10 --network "none" ${img} >/dev/null 2>&1
docker cp ${src} ${t}:/home/${main} >/dev/null 2>&1
docker cp ${input} ${t}:/home/input.txt >/dev/null 2>&1
docker start ${t} >/dev/null 2>&1
timeout ${timer} docker wait ${t} >/dev/null 2>&1
check=$(docker inspect ${t} --format='{{.State.ExitCode}}')
docker cp ${t}:/home/output.txt ${out} >/dev/null 2>&1
docker cp ${t}:/home/comp.txt ${comp} >/dev/null 2>&1
docker rm -f ${t} >/dev/null 2>&1
exit ${check}

ここがなるべくの部分です。各テストケースをファイルに書き込んでシェルスクリプトを実行してその返り値でACやWAの判定をします。(\nをいれてT.appendするよりunlinesしたほうが速そうということに執筆時に気が付きました修正します)

参考文献

https://qiita.com/t10471/items/70af33487ece780b6c10

提出

src/AtCoderLib.hs

atSubmit :: AtFunc
atSubmit contests msg = do
 postSubmit msg contests
 let submitStatus = "submit"
 return (submitStatus, contests)

src/Lib.hs

postSubmit :: AtSubmit -> Contest -> IO ()
postSubmit msg ud = case (cname msg, qname msg, file msg) of
 (Just cm, Just qm, Just fm) -> do
  source <- TIO.readFile $ T.unpack $ V.foldl1 T.append [userdir msg, T.singleton '/', fm]
  let questurl = V.foldl1 T.append ["https://atcoder.jp/contests/", cm, "/submit"]
  res <- postRequestWrapper questurl (cookie ud) [ ("data.TaskScreenName", qm), ("data.LanguageId", "3014")
                                                 , ("sourceCode", source), ("csrf_token", csrf_token ud)]
  return ()
 _ -> return ()

クッキーとcsrf_tokenを一緒にPOSTします。ACやWAはこの時点では分かりません。

結果の表示

src/AtCoderLib.hs

atResult :: AtFunc
atResult contests msg = case cname msg of
 Just cm -> do
  res <- getContestResult cm contests
  return (res, contests)
 Nothing -> if V.null (questions contests) then return ("nothing", contests) else do
  res <- T.unlines <$> loop ((rmDup.V.map (T.takeWhile (/='_').T.takeWhileEnd (/='/').qurl)) (questions contests)) contests
  return (res, contests)
   where
    loop :: V.Vector T.Text -> Contest -> IO [T.Text]
    loop quest cont = if V.null quest then return [] else do
     res <- getContestResult (V.head quest) cont
     bef <- loop (V.tail quest) cont
     return $ T.append "===== " (T.append (V.head quest) $ T.append " =====\n" res):bef

src/Lib.hs

getContestResult :: T.Text -> Contest -> IO T.Text
getContestResult cnt ud = if T.null cnt then return T.empty else do
 res <- getRequestWrapper (V.foldl1 T.append ["https://atcoder.jp/contests/", cnt, "/submissions/me"]) (cookie ud)
 if getResponseStatus res /= status200 then return T.empty
 else resultIO.fromDocument.parseLBS.getResponseBody $ res
  where
   resultIO :: Cursor -> IO T.Text
   resultIO cursor = do
    let cn = Prelude.concatMap content.lineNGet 4.Prelude.concatMap child $ cursor $// attributeIs "class" "table-responsive" 
                                                                                   &// element "td"
                                                                                   &// element "a"
        result = Prelude.concatMap content.Prelude.concatMap child $ cursor $// attributeIs "class" "table-responsive"
                                                                            &// element "td"
                                                                            &// attributeIs "aria-hidden" "true"
    return $ zipLines cn result
   lineNGet :: Int -> [Cursor] -> [Cursor]
   lineNGet n l = if Prelude.length l >= n then Prelude.head l:lineNGet n (drop n l) else []
   zipLines :: [T.Text] -> [T.Text] -> T.Text
   zipLines [] [] = T.empty
   zipLines [c] [r] = V.foldl1 T.append [c, " : ", r]
   zipLines (c:n) (r:s) = V.foldl1 T.append [c, " : ", r, "\n", zipLines n s]

getリクエストを投げてスクレイピングします。

ログアウトとサーバの停止

src/AtCoderLib.hs

atLogout :: AtFunc
atLogout contests msg = postLogout contests >>= \x -> return (x, nullContest)

src/Lib.hs

postLogout :: Contest -> IO T.Text
postLogout ud = do
 res <- postRequestWrapper "https://atcoder.jp/logout" (cookie ud) [("csrf_token", csrf_token ud)]
 return $ if getResponseStatus res /= status200 then "failuar logout" else "accept logout"

(必要かどうかは怪しいですが)ログアウトしてサーバを停止させます。

クライアントの実装

src/AtCoder.hs

client :: [T.Text] -> Socket -> IO()
client msg sock = do
 cwd <- T.pack <$> getCurrentDirectory
 NSBS.send sock $ toStrict.DA.encode $ createAtSubmit msg cwd
 json <- fromStrict <$> NSBS.recv sock 1024
 TIO.putStrLn $ case DA.decode json of Nothing -> "json parse error"
                                       Just x  -> case restext x of Nothing -> "responce Nothing"
                                                                    Just x  -> x

引数をAtSubmitに入れてjsonにして送り、結果を出力します。

main関数

app/Main.hs

{-# LANGUAGE BangPatterns #-}
module Main where

import Lib
import UnixDomainSocket
import AtCoderLib

import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Data.Vector as V
import System.Environment
import System.IO
import System.Posix.Daemonize

sockpath = "/.local/lib/atsubmit/atsubmit.sock"

main :: IO ()
main = do
 arg <- Prelude.map T.pack <$> getArgs
 if null arg then do
  (b,c) <- atLogin nullContest nullAtSubmit -- login 
  if Prelude.null (cookie c) then TIO.putStrLn b >> TIO.putStrLn (csrf_token c)
  else TIO.putStrLn b >> getEnv "HOME" >>= \path -> daemonize $ runServer c (path ++ sockpath) server 
 else getEnv "HOME">>= \path -> sendServer (path ++ sockpath) $ client arg

引数があるかないかでサーバ用かクライアント用かを分けています。サーバ用ならログイン処理をしてデーモン化、クライアント用ならそのままクライアント用の実行をして終了します

参考文献

　https://www.stackage.org/package/hdaemonize

デモ

vimのpluginの例です。
取得したhtmlファイルはブラウザで確認してください。

今後の予定

dockerの操作をシェルスクリプトに丸投げしているのでこれをdocker engine apiを叩いてHaskellのみでできるようになりたいです。また、クライアント側を別の言語で書いてもよい様にAPI作ってリファレンス書く練習してもよいなぁと思っています。

まとめ

以前同じような自動提出プログラムを書いた時に先輩からエディタのプラグインにできるような実装にするといいかもと言われて1年かけて作るかぁとなりました。ただし実装はとてもきたないのできれいな実装に書き直したいとおもっています。
また、githubで開発は続けています。

追記

別言語でもコードテストや提出をできるようにしました

(なるべく)HaskellでAtCoderに参加したい

はじめに

おことわり

追記

開発環境

その他に使用したツール

操作手順と本プログラムの要件

参加手順とやりたいこと

設計

サーバ

各機能への命名

サーバの受け取るデータの形式

クライアント

実装

代数データ型

aeson

参考文献

UnixDomainSocket

参考文献

サーバの実装

参考文献

各関数の実装

ログイン

問題の取得

参考文献

テストケースの表示

テスト

参考文献

提出

結果の表示

ログアウトとサーバの停止

クライアントの実装

main関数

参考文献

デモ

今後の予定

まとめ

追記

参考文献