{-# LANGUAGE ViewPatterns #-}
module Main (main) where
import Safe
import Data.List
import System.IO
import System.Exit
import Web.DDP.Deadpan
import System.Environment
import Data.Maybe
import Control.Concurrent.Chan
import qualified System.Console.Haskeline as R
main :: IO ()
main = getArgs >>= go
go :: [String] -> IO ()
go xs | hashelp xs = help
go (getVersion -> (v, [url])) = void $ run (getURI url) v
go _ = help >> exitFailure
-- TODO: No sane person would use this Maybe Maybe monstrosity, but aren't we all a little mad?
run :: Either Error Params -> Maybe (Maybe Version) -> IO ()
run (Left err ) _ = hPutStrLn stderr err >> exitFailure
run _ (Just Nothing) = hPutStrLn stderr "Incorrect version specified..." >> exitFailure
run (Right params) (Just (Just v)) = runPingClientVersion params v (logEverything >> sendMessages)
run (Right params) Nothing = runPingClient params (logEverything >> sendMessages)
-- TODO: Allow a full DSL to be used rather than just messages?
--
sendMessages :: DeadpanApp ()
sendMessages = do
c <- liftIO newChan
let settings = R.defaultSettings { R.autoAddHistory = True }
void $ fork $ liftIO $ R.runInputT settings (inOutLoop c)
contents <- liftIO (getChanContents c)
mapM_ sendPossibleMessage (catMaybes (takeWhile isJust contents))
inOutLoop :: Chan (Maybe String) -> R.InputT IO ()
inOutLoop c = do
maybeLine <- R.getInputLine ""
case maybeLine of
Nothing -> liftIO $ writeChan c Nothing -- EOF / control-d
Just "exit" -> liftIO $ writeChan c Nothing
Just "help" -> liftIO instructions >> inOutLoop c
Just "" -> inOutLoop c
Just line -> liftIO (writeChan c (Just line)) >> inOutLoop c
sendPossibleMessage :: String -> DeadpanApp ()
sendPossibleMessage msgStr = do
let decoded = decodeString msgStr
case decoded of Just m -> sendData m
Nothing -> liftIO $ putStrLn "Invalid Message"
getVersion :: [String] -> (Maybe (Maybe Version), [String])
getVersion ss = (extractVersion ss, deleteVersion ss)
extractVersion :: [String] -> Maybe (Maybe Version)
extractVersion ("-v" : x : _ ) = Just $ readMay x
extractVersion ("--version" : x : _ ) = Just $ readMay x
extractVersion ( _ : xs) = extractVersion xs
extractVersion _ = Nothing
deleteVersion :: [String] -> [String]
deleteVersion ("-v" : _ : xs) = deleteVersion xs
deleteVersion ("--version" : _ : xs) = deleteVersion xs
deleteVersion ( x : xs) = x : deleteVersion xs
deleteVersion xs = xs
hashelp :: [String] -> Bool
hashelp xs = any (`elem` xs) (words "-h --help")
help :: IO ()
help = hPutStrLn stderr $ "Usage: deadpan [-h | --help] [ ( -v | --version ) "
++ "( " ++ intercalate " | " (map show $ reverse [minBound :: Version ..]) ++ " )"
++ " ] <URL>"
instructions :: IO ()
instructions = hPutStrLn stderr $ unlines [ "Input EJSON messages to send to the server."
, "\"exit\" to exit."
, "\"help\" for instructions."
]