{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Labsat where import Control.Concurrent.Async.Lifted (race_) import Control.Concurrent.Lifted (threadDelay) import Data.Attoparsec.ByteString import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C import Data.Conduit import Data.Conduit.Attoparsec import qualified Data.Conduit.Binary as B import Data.Conduit.Network import Data.Text.Encoding (encodeUtf8) import Labsat.Ctx import Labsat.Parser import Labsat.Types import Preamble import System.IO hiding (print, putStrLn) -------------------------------------------------------------------------------- -- | Bracketed opening, closing of a binary file. -- withBinaryFile' :: (MonadIO m, MonadBaseControl IO m) => FilePath -> (Handle -> m a) -> m a withBinaryFile' f = flip bracket (liftIO . hClose) $ do h <- liftIO $ openBinaryFile f AppendMode liftIO $ hSetBuffering h LineBuffering pure h -- | Add Labsat end-of-line delimiters and send command -- sendCmd :: MonadLabsatCtx c m => ByteString -> m () sendCmd s = runResourceT $ do ad <- view lsAppData yield (s <> "\r\r\n") =$= B.conduitFile "labsat.log" $$ appSink ad -- | Strip ANSI color codes -- colorStripper :: MonadIO m => Conduit ByteString m ByteString colorStripper = do mx <- await case mx of Nothing -> pure () Just bs -> case BS.findIndex isEscape bs of Nothing -> do yield bs colorStripper Just idx -> do let (prefix, escape) = BS.splitAt idx bs yield prefix case parse parseColorSeq escape of Fail{} -> do let (h,t) = BS.splitAt 1 escape yield h leftover t Partial _ -> leftover escape Done i _ -> leftover i colorStripper -- | Receive command response and strip color codes -- receiveResp :: MonadLabsatCtx c m => Parser a -> m a receiveResp p = runResourceT $ do ad <- view lsAppData appSource ad =$= colorStripper =$= B.conduitFile "labsat.log" $$ sinkParser p -- | Receive command response, strip color codes, and log to file -- logResp :: MonadLabsatCtx c m => FilePath -> m () logResp lf = runResourceT $ do ad <- view lsAppData withBinaryFile' lf $ \lh -> appSource ad =$= colorStripper $$ B.sinkHandle lh -- | Parse connection message -- connectMsg :: (MonadLabsatCtx c m) => m () connectMsg = receiveResp parseFirstLabsatMsg >> pure () -- | Send a command and parser for its response. -- command :: MonadLabsatCtx c m => ByteString -> Parser a -> m a command c p = do delay <- view lsDelay sendCmd c traverse_ (threadDelay . (*1000000)) delay receiveResp $ parseCommandAck c *> p -- | Send a command and parse for OK and the prompt -- okCommand :: (MonadLabsatCtx c m) => ByteString -> m ByteString okCommand = flip command okPrompt -- Swallow first message, capture and print second one (debug) -- debugRecv :: ByteString -> ByteString -> Int -> IO () debugRecv msg host port = runCtx $ runStatsCtx $ runLabsatCtx host port Nothing $ do msg0 <- receiveResp parseUntilPrompt putStrLn "First message:" print msg0 putStrLn "Debug message:" sendCmd msg res <- receiveResp parseUntilPrompt print (res <> "LABSAT_V3 >") testCommand :: (MonadStatsCtx c m, Show a) => ByteString -> Int -> TransT LabsatCtx m a -> m () testCommand host port cmd = runLabsatCtx host port Nothing $ do void $ receiveResp parseFirstLabsatMsg res <- cmd print res -------------------------------------------------------------------------------- -- Commands -------------------------------------------------------------------------------- -- | Optionally create argument string from Maybe a -- -- | TODO fix this function so output doesn't have escaped quotes from 'show' -- argFromMaybe :: (Show a) => ByteString -> Maybe a -> ByteString argFromMaybe a m = case m of Nothing -> "" Just m' -> a ++ showToBs m' -- Int -> ByteString -- intToBs :: Int -> ByteString intToBs = C.pack . show -- Bool -> ByteString -- boolToBs :: Bool -> ByteString boolToBs = bool "N" "Y" showToBs :: Show a => a -> ByteString showToBs = C.pack . show -------------------------------------------------------------------------------- -- Help command -------------------------------------------------------------------------------- -- | HELP command. -- help :: MonadLabsatCtx c m => m HelpCommands help = command "HELP" parseHelp -------------------------------------------------------------------------------- -- Media command -------------------------------------------------------------------------------- -- | MEDIA:LIST command. -- mediaList :: MonadLabsatCtx c m => m MediaList mediaList = command "MEDIA:LIST" parseMediaList -- | MEDIA:CHDIR:\ command. -- mediaChdirRoot :: MonadLabsatCtx c m => m ByteString mediaChdirRoot = command "MEDIA:CHDIR:\\" parseMediaChdir -- | MEDIA:CHDIR:.. command. -- mediaChdirUp :: MonadLabsatCtx c m => m ByteString mediaChdirUp = command "MEDIA:CHDIR:.." parseMediaChdir -- | MEDIA:CHDIR: