diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (C) 2018 Swift Navigation Inc. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/labsat.cabal b/labsat.cabal new file mode 100644 --- /dev/null +++ b/labsat.cabal @@ -0,0 +1,68 @@ +name: labsat +version: 0.0.0 +synopsis: LabSat TCP Interface Wrapper +description: labsat provides a wrapper around the LabSat3 TCP interface +homepage: https://github.com/swift-nav/labsat +license: MIT +license-file: LICENSE +author: Swift Navigation Inc. +maintainer: Swift Navigation +copyright: Copyright (C) 2015-2018 Swift Navigation, Inc. +build-type: Simple +cabal-version: >= 1.22 + +source-repository head + type: git + location: git@github.com:swift-nav/labsat.git + +library + hs-source-dirs: src + exposed-modules: Labsat + , Labsat.Ctx + , Labsat.Types + , Labsat.Parser + default-language: Haskell2010 + ghc-options: -Wall + build-depends: base >= 4.8 && < 5 + , attoparsec + , bytestring + , conduit + , conduit-extra + , lifted-async + , lifted-base + , scientific + , preamble + , text + +executable labsat + default-language: Haskell2010 + hs-source-dirs: main + main-is: labsat-cli.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -O2 + build-depends: base + , labsat + , optparse-generic + , preamble + , text + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + other-modules: Test.Labsat.Parser + build-depends: attoparsec + , base + , bytestring + , labsat + , preamble + , tasty + , tasty-hunit + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + +--executable shake-labsat +-- main-is: Shakefile.hs +-- ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall +-- build-depends: base >= 4.8 && < 5 +-- , shakers +-- efault-language: Haskell2010 diff --git a/main/labsat-cli.hs b/main/labsat-cli.hs new file mode 100644 --- /dev/null +++ b/main/labsat-cli.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | LabSat telnet interface +-- +import Options.Generic +import Preamble +import Labsat + +-- | Args +-- +-- Program arguments. +-- +data Args = Args + { + ip :: Text + -- ^ Host IP. + , port :: Int + -- ^ Host port. + } deriving (Show, Generic) + +instance ParseRecord Args + +-- | Run Labsat Telnet Wrapper +-- +main :: IO () +main = do + args <- getRecord "Labsat Telnet Wrapper" + labsatMain + (ip args) + (port args) diff --git a/src/Labsat.hs b/src/Labsat.hs new file mode 100644 --- /dev/null +++ b/src/Labsat.hs @@ -0,0 +1,504 @@ +{-# 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 :: MonadTcpCtx c m => ByteString -> m () +sendCmd s = do + ad <- view tcpAppData + yield (s <> "\r\r\n") $$ 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 :: MonadTcpCtx c m => Parser a -> m a +receiveResp p = runResourceT $ do + ad <- view tcpAppData + appSource ad =$= colorStripper $$ sinkParser p + +-- | Receive command response, strip color codes, and log to file +-- +logResp :: MonadTcpCtx c m => FilePath -> m () +logResp lf = runResourceT $ do + ad <- view tcpAppData + withBinaryFile' lf $ \lh -> + appSource ad =$= colorStripper $$ B.sinkHandle lh + +-- | Send a command and parser for its response. +-- +command :: (MonadTcpCtx c m) => ByteString -> Parser a -> m a +command c p = do + sendCmd c + receiveResp $ parseCommandAck c *> p + +-- | Send a command and parse for OK and the prompt +-- +okCommand :: (MonadTcpCtx 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 $ + runGeneralTCPClient (clientSettings port host) $ + flip runTcpCtx $ 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 TcpCtx m a -> m () +testCommand host port cmd = + runGeneralTCPClient (clientSettings port host) $ + flip runTcpCtx $ 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 :: MonadTcpCtx c m => m HelpCommands +help = command "HELP" parseHelp + +-------------------------------------------------------------------------------- +-- Media command +-------------------------------------------------------------------------------- + +-- | MEDIA:LIST command. +-- +mediaList :: MonadTcpCtx c m => m MediaList +mediaList = command "MEDIA:LIST" parseMediaList + +-- | MEDIA:CHDIR:\ command. +-- +mediaChdirRoot :: MonadTcpCtx c m => m ByteString +mediaChdirRoot = command "MEDIA:CHDIR:\\" parseMediaChdir + +-- | MEDIA:CHDIR:.. command. +-- +mediaChdirUp :: MonadTcpCtx c m => m ByteString +mediaChdirUp = command "MEDIA:CHDIR:.." parseMediaChdir + +-- | MEDIA:CHDIR: command. +-- +mediaChdir :: MonadTcpCtx c m => ByteString -> m ByteString +mediaChdir d = command ("MEDIA:CHDIR:" <> d) parseMediaChdir + +-- | MEDIA:PROTECT:Y/N:FILE command. +-- +mediaProtect :: MonadTcpCtx c m => Bool -> ByteString -> m ByteString +mediaProtect b f = okCommand $ "MEDIA:PROTECT:" <> bool "N:" "Y:" b <> f + +-- | MEDIA:DELETE:FILE command. +-- +mediaDelete :: MonadTcpCtx c m => ByteString -> m ByteString +mediaDelete f = okCommand $ "MEDIA:DELETE:" <> f + +-- | MEDIA:SELECT:SD/USB/SATA command. +-- +mediaSelect :: MonadTcpCtx c m => MediaType -> m ByteString +mediaSelect s = okCommand $ "MEDIA:SELECT:" <> showToBs s + +-------------------------------------------------------------------------------- +-- Play command +-------------------------------------------------------------------------------- + +-- | PLAY command. +-- +play :: MonadTcpCtx c m => ByteString -> m ByteString +play f = command ("PLAY:FILE:" <> f) (parsePlay f) + +-- | PLAY command that supports FOR and FROM +-- +play' :: MonadTcpCtx c m => PlayConf -> m ByteString +play' pc = command cmd (parsePlay file') + where + for' = argFromMaybe ":FOR:" $ pc ^.pcFor + from' = argFromMaybe ":FROM:" $ pc ^.pcFrom + file' = pc ^. pcFile + cmd = "PLAY:FILE:" <> file' <> for' <> from' + +-- | PLAY:STOP command. +-- +playStop :: MonadTcpCtx c m => m ByteString +playStop = okCommand "PLAY:STOP" + +-- | PLAY:? command. +-- +playStatus :: MonadTcpCtx c m => m PlayStatus +playStatus = command "PLAY:?" parsePlayStatus + +-------------------------------------------------------------------------------- +-- Type command +-------------------------------------------------------------------------------- + +-- | TYPE command. Named 'info' to avoid the obvious conflict. +-- +info :: MonadTcpCtx c m => m Info +info = command "TYPE" parseInfo + +-------------------------------------------------------------------------------- +-- Find command +-------------------------------------------------------------------------------- + +-- | FIND command. +-- +find :: MonadTcpCtx c m => m ByteString +find = okCommand "FIND" + +-------------------------------------------------------------------------------- +-- Mon command +-------------------------------------------------------------------------------- + +-- | MON:NMEA:ON command. +-- +nmeaOn :: MonadTcpCtx c m => m ByteString +nmeaOn = okCommand "MON:NMEA:ON" + +-- | MON:NMEA:OFF command. +-- +nmeaOff :: MonadTcpCtx c m => m ByteString +nmeaOff = okCommand "MON:NMEA:OFF" + +-- | Capture NMEA log for 'n' seconds +-- +nmeaLog :: (MonadIO m, MonadTcpCtx c m) => Int -> FilePath -> m () +nmeaLog n f = do + void nmeaOn + race_ (threadDelay $ n * 1000000) $ logResp f + void nmeaOff + pure () + +-- | MON:LOC command. +-- +monLoc :: MonadTcpCtx c m => m Location +monLoc = command "MON:LOC" parseMonLoc + +-- | MON:SAT command. +-- +monSat :: MonadTcpCtx c m => m [ConstellationCNO] +monSat = command "MON:SAT" parseMonSat + +-------------------------------------------------------------------------------- +-- Rec command +-------------------------------------------------------------------------------- + +-- | REC command. +-- +rec :: MonadTcpCtx c m => m ByteString +rec = command "REC" parseRec + +-- | REC command that supports FILE and FOR. +-- +rec' :: MonadTcpCtx c m => RecordConf -> m ByteString +rec' rc = command cmd parseRec + where + file' = argFromMaybe ":FILE:" $ rc ^. rcFile + for' = argFromMaybe ":FOR:" $ rc ^. rcFor + cmd = "REC" <> file' <> for' + +-- | REC:STOP command. +-- +recStop :: MonadTcpCtx c m => m ByteString +recStop = okCommand "REC:STOP" + +-- | REC:? command. +-- +recStatus :: MonadTcpCtx c m => m RecordStatus +recStatus = command "REC:?" parseRecordStatus + +-------------------------------------------------------------------------------- +-- Mute command +-------------------------------------------------------------------------------- + +-- | MUTE command. +-- +mute :: MonadTcpCtx c m => Bool -> m ByteString +mute b = okCommand ("MUTE:" <> boolToBs b) + +-- | MUTE command that supports individual channel control. +-- +mute' :: MonadTcpCtx c m => MuteConf -> m MuteConf +mute' mc = + case mc ^. mcMuteAll of + Just b -> command ("MUTE:" <> b2c b) parseMute + Nothing -> do + let ch1 = fromMaybeBoolToMuteStr "CH1" $ mc ^. mcMuteCh1 + ch2 = fromMaybeBoolToMuteStr "CH2" $ mc ^. mcMuteCh2 + ch3 = fromMaybeBoolToMuteStr "CH3" $ mc ^. mcMuteCh3 + command ("MUTE:" <> ch1 <> ch2 <> ch3) parseMute + where + b2c = boolToBs + fromMaybeBoolToMuteStr prefix m = case m of + Nothing -> "" + Just b -> ":" ++ prefix ++ ":" ++ b2c b + +-------------------------------------------------------------------------------- +-- Attentuation command +-------------------------------------------------------------------------------- + +-- | ATTN command. +-- +attn :: MonadTcpCtx c m => Int -> m AttnConf +attn i = command ("ATTN:" <> intToBs i) parseAttn + +-- | ATTN command that supports individual channel control. +-- +attn' :: MonadTcpCtx c m => AttnConf -> m AttnConf +attn' ac = + case ac ^. acAttnAll of + Just i -> command ("ATTN:" <> intToBs i) parseAttn + Nothing -> do + let ch1 = fromMaybeIntToAttnStr "CH1" $ ac ^. acAttnCh1 + ch2 = fromMaybeIntToAttnStr "CH2" $ ac ^. acAttnCh2 + ch3 = fromMaybeIntToAttnStr "CH3" $ ac ^. acAttnCh3 + command ("ATTN:" <> ch1 <> ch2 <> ch3) parseAttn + where + fromMaybeIntToAttnStr prefix m = case m of + Nothing -> "" + Just i -> ":" ++ prefix ++ ":" ++ intToBs i + +-------------------------------------------------------------------------------- +-- Configuration command +-------------------------------------------------------------------------------- + +-- | CONF:PLAY:LOOP command. +-- +confPlayLoop :: MonadTcpCtx c m => Bool -> m ByteString +confPlayLoop b = okCommand ("CONF:PLAY:LOOP:" <> boolToBs b) + +-- | CONF:PLAY:PAUSE command. +-- +confPlayPause :: MonadTcpCtx c m => Int -> m ByteString +confPlayPause i = okCommand ("CONF:PLAY:PAUSE:" <> intToBs i) + +-- | CONF:PLAY:FOR command. +-- +confPlayFor :: MonadTcpCtx c m => Int -> m ByteString +confPlayFor i = okCommand ("CONF:PLAY:FOR:" <> intToBs i) + +-- | CONF:PLAY:FROM command. +-- +confPlayFrom :: MonadTcpCtx c m => Int -> m ByteString +confPlayFrom i = okCommand ("CONF:PLAY:FROM:" <> intToBs i) + +-- | CONF:PLAY:FOR:FROM command. +-- +confPlayForFrom :: MonadTcpCtx c m => Int -> Int -> m ByteString +confPlayForFrom i j = okCommand ("CONF:PLAY:FOR:" <> intToBs i <> ":FROM:" <> intToBs j) + +-- | CONF:REC:FOR command. +-- +confRecFor :: MonadTcpCtx c m => Int -> m ByteString +confRecFor i = okCommand ("CONF:REC:FOR:" <> intToBs i) + +-- | CONF:SETUP:DISP:CONT command. +-- +confContrast :: MonadTcpCtx c m => Int -> m ByteString +confContrast i = okCommand ("CONF:SETUP:DISP:CONT:" <> intToBs i) + +-- | CONF:SETUP:DISP:BRIG command. +-- +confBrightness :: MonadTcpCtx c m => Int -> m ByteString +confBrightness i = okCommand ("CONF:SETUP:DISP:BRIG:" <> intToBs i) + +-- | CONF:SETUP:PSAV command. +-- +confPsav :: MonadTcpCtx c m => Bool -> m ByteString +confPsav b = okCommand ("CONF:SETUP:PSAV:" <> boolToBs b) + +-- | CONF:SETUP:SYNC command. +-- +confSync :: MonadTcpCtx c m => Bool -> m ByteString +confSync b = okCommand ("CONF:SETUP:SYNC:" <> boolToBs b) + + +-- | CONF:SETUP:BEEP command. +-- +confBeep :: MonadTcpCtx c m => Bool -> m ByteString +confBeep b = okCommand ("CONF:SETUP:BEEP:" <> boolToBs b) + + +-- | CONF:SETUP:TIME:UTC command. +-- +confTimeUTC :: MonadTcpCtx c m => m ByteString +confTimeUTC = okCommand "CONF:SETUP:TIME:UTC:Y" + +-- | CONF:SETUP:TIME:MAN command. +-- +confTimeManual :: MonadTcpCtx c m + => ByteString + -> ByteString + -> ByteString + -> ByteString + -> ByteString + -> ByteString + -> m ByteString +confTimeManual year month day hours minutes seconds = + okCommand ("CONF:SETUP:TIME:UTC:N:MAN:" <> intercalate ":" [year, month, day, hours, minutes, seconds]) + +-- | CONF:SETUP:DIGI command. +-- +confDigi :: MonadTcpCtx c m => CANChannel -> DigitalFunction -> m ByteString +confDigi ch df = okCommand ("CONF:SETUP:DIGI:" <> showToBs ch <> ":" <> showToBs df) + +-- | CONF:SETUP:CAN:CH*:BAUD command. +-- +confCANBaud :: MonadTcpCtx c m => CANChannel -> Double -> m Double +confCANBaud ch val = command ("CONF:SETUP:CAN:" <> showToBs ch <> ":BAUD:" <> showToBs val) parseCANBaud + + +-- | CONF:SETUP:CAN:SILENT command. +-- +confCANSilent :: MonadTcpCtx c m => Bool -> m ByteString +confCANSilent b = okCommand ("CONF:SETUP:CAN:SILENT:" <> boolToBs b) + +-- | CONF:SETUP:CAN:LOGFILE command. +-- +confCANLogfile :: MonadTcpCtx c m => Bool -> m ByteString +confCANLogfile b = okCommand ("CONF:SETUP:CAN:LOGFILE:" <> boolToBs b) + +-- | CONF:SETUP:CAN:REPLAYFILE command. +-- +confCANReplayfile :: MonadTcpCtx c m => Bool -> m ByteString +confCANReplayfile b = okCommand ("CONF:SETUP:CAN:REPLAYFILE:" <> boolToBs b) + +-- | CONF:SETUP:CLKREF:OCXO command. +-- +confClkRefOCXO :: MonadTcpCtx c m => m ByteString +confClkRefOCXO = okCommand "CONF:SETUP:CLKREF:OCXO" + +-- | CONF:SETUP:CLKREF:TCXO command. +-- +confClkRefTCXO :: MonadTcpCtx c m => m ByteString +confClkRefTCXO = okCommand "CONF:SETUP:CLKREF:TCXO" + +-- | CONF:SETUP:CLKREF:EXT command. +-- +confClkRefEXT :: MonadTcpCtx c m => m ByteString +confClkRefEXT = okCommand "CONF:SETUP:CLKREF:EXT" + +-- | CONF:SETUP:CLKREF:REFOUT command. +-- +confClkRefout :: MonadTcpCtx c m => Bool -> m ByteString +confClkRefout b = okCommand ("CONF:SETUP:CLKREF:REFOUT:" <> boolToBs b) + +-- | CONF:CONS command. +-- +confConstellationPreset :: MonadTcpCtx c m => ConstellationPresetConf -> m ConstellationPresetConf +confConstellationPreset cc = command ("CONF:CONS:" <> showToBs cc) parseConsPreset + +-- | CONF:CONS command. +-- +confConstellationFreq :: MonadTcpCtx c m => ConstellationFreqConf -> m ConstellationFreqConf +confConstellationFreq cc = command ("CONF:CONS:" <> showToBs cc) parseConsFreq + +-- | CONF:? command. +-- +confQuery :: MonadTcpCtx c m => m ByteString +confQuery = command "CONF:?" parseUntilPrompt + +-- | Labsat Main +-- +labsatMain :: MonadControl m => Text -> Int -> m () +labsatMain ip port= do + putStrLn "Labsat!" + print ip + print port + + -- Example + runCtx $ runStatsCtx $ + runGeneralTCPClient (clientSettings port $ encodeUtf8 ip) $ + flip runTcpCtx $ do + void $ receiveResp parseFirstLabsatMsg + resp <- info + print resp diff --git a/src/Labsat/Ctx.hs b/src/Labsat/Ctx.hs new file mode 100644 --- /dev/null +++ b/src/Labsat/Ctx.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} + +module Labsat.Ctx where + +import Data.Conduit.Network (AppData) +import Preamble + +data TcpCtx = TcpCtx + { _tcpStatsCtx :: StatsCtx + , _tcpAppData :: AppData + } + +$(makeClassyConstraints ''TcpCtx [''HasStatsCtx]) + +instance HasStatsCtx TcpCtx where + statsCtx = tcpStatsCtx + +instance HasCtx TcpCtx where + ctx = statsCtx . ctx + +type MonadTcpCtx c m = + ( MonadStatsCtx c m + , HasTcpCtx c + ) + +runTcpCtx :: MonadStatsCtx c m => AppData -> TransT TcpCtx m a -> m a +runTcpCtx ad action = do + e <- view statsCtx + runTransT (TcpCtx e ad) action + diff --git a/src/Labsat/Parser.hs b/src/Labsat/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Labsat/Parser.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Labsat.Parser where + + +import qualified Data.ByteString as BS +import Data.Attoparsec.ByteString +import Data.Attoparsec.ByteString.Char8 (char, decimal, double, isDigit_w8, isEndOfLine, scientific, signed) +import Labsat.Types +import Preamble hiding (takeWhile) + + +-------------------------------------------------------------------------------- +-- Helper Parsers +-------------------------------------------------------------------------------- + +prompt :: Parser ByteString +prompt = string "LABSAT_V3 >" + +newline :: Parser ByteString +newline = string "\r\r\n" + +ok :: Parser ByteString +ok = string "OK" + +err :: Parser ByteString +err = string "ERR" + +colon :: Word8 -> Bool +colon = (== 58) + +isETX :: Word8 -> Bool +isETX = (==03) + +etx :: Parser Word8 +etx = word8 03 + +isEscape :: Word8 -> Bool +isEscape = (== 27) + +notNewline :: Word8 -> Bool +notNewline w = w /= 10 && w /= 13 + +parseNotNewline :: Parser Word8 +parseNotNewline = satisfy notNewline + +mediaDelim :: Parser ByteString +mediaDelim = string " \ESC[40G " + +takeDigits :: Parser ByteString +takeDigits = takeWhile1 isDigit_w8 + +-- | Parse OK followed by prompt +-- +okPrompt :: Parser ByteString +okPrompt = ok <* takeNewlines <* prompt + +-- | Parse comma separated lists +-- +commaSep :: Parser ByteString -> Parser [ByteString] +commaSep = flip sepBy' (char ',') + +-- | take [\r\n]+ +-- +takeNewlines :: Parser () +takeNewlines = satisfy isEndOfLine *> skipWhile isEndOfLine + +-- | Parse everything up to [\r\n]+ +-- +parseLabsatLine :: Parser ByteString +parseLabsatLine = takeWhile1 (not . isEndOfLine) <* takeNewlines + +-- | Parse lines until next Labsat prompt +-- +parseLabsatLines :: Parser [ByteString] +parseLabsatLines = manyTill parseLabsatLine prompt + +-- | Parse everything until next prompt (debug) +-- +parseUntilPrompt :: Parser ByteString +parseUntilPrompt = BS.pack <$> manyTill anyWord8 prompt + +-- | Parse everything up to and including next prompt (debug) +-- +parseThroughPrompt :: Parser ByteString +parseThroughPrompt = do + x <- parseUntilPrompt + pure $ x <> "LABSAT_V3 >" + +-- | Parse echoed command followed by newline(s) +-- +parseCommandAck :: ByteString -> Parser ByteString +parseCommandAck cmd = string cmd <* takeNewlines + +-- | Parse ANSI Color Escape Sequence +-- +parseColorSeq :: Parser ByteString +parseColorSeq = do + esc <- string "\ESC[" + n <- takeDigits + m <- string "m" + pure $ BS.concat [esc, n, m] + +-- | Parse Labsat header +-- +takeLabsatHeader :: Parser ByteString +takeLabsatHeader = takeWhile1 (not . isETX) <* etx + +-- | Parse Y/N +-- +parseYN :: Parser Bool +parseYN = + (string "Y" >> pure True) <|> + (string "N" >> pure False) + +-- | Parse IP address +-- +-- | TODO make sure its a valid IP address +parseIP :: Parser ByteString +parseIP = do + octet1 <- takeDigits + void $ char '.' + octet2 <- takeDigits + void $ char '.' + octet3 <- takeDigits + void $ char '.' + octet4 <- takeDigits + pure $ intercalate "." [octet1, octet2, octet3, octet4] + +-- | Parse Duration HH:MM:SS +-- +parseDuration :: Parser ByteString +parseDuration = do + hh <- takeWhile isDigit_w8 + void $ char ':' + mm <- takeWhile isDigit_w8 + void $ char ':' + ss <- takeWhile isDigit_w8 + pure $ intercalate ":" [hh, mm, ss] + +-- | Parse In Use Error +-- +parseInUse :: Parser ByteString +parseInUse = takeLabsatHeader *> string "in use with " *> parseIP <* takeNewlines + +-- | Parse First Labsat Message +-- +parseFirstLabsatMsg :: Parser ByteString +parseFirstLabsatMsg = takeLabsatHeader <* takeNewlines *> prompt + +-------------------------------------------------------------------------------- +-- HELP Parsers +-------------------------------------------------------------------------------- + +parseHelp :: Parser HelpCommands +parseHelp = + HelpCommands <$> ("Current commands are : " <* takeNewlines *> parseLabsatLines) + +-------------------------------------------------------------------------------- +-- MEDIA Parsers +-------------------------------------------------------------------------------- + +parseMediaFile :: Parser Media +parseMediaFile = File <$> (BS.pack <$> manyTill parseNotNewline mediaDelim) <*> parseDuration <* newline + +parseMediaDir :: Parser Media +parseMediaDir = Dir <$> (BS.pack <$> manyTill parseNotNewline newline) + +parseMedia :: Parser Media +parseMedia = parseMediaFile <|> parseMediaDir + +parseMediaList :: Parser MediaList +parseMediaList = MediaList <$> manyTill parseMedia (newline *> prompt) + +parseMediaChdir :: Parser ByteString +parseMediaChdir = takeWhile notNewline <* takeNewlines <* ok <* takeNewlines <* prompt + +-------------------------------------------------------------------------------- +-- PLAY Parsers +-------------------------------------------------------------------------------- + +parsePlayFile :: ByteString -> Parser ByteString +parsePlayFile = string + +parsePlayIdle :: Parser PlayStatus +parsePlayIdle = do + void "PLAY:IDLE" + pure PlayIdle + +parsePlaying :: Parser PlayStatus +parsePlaying = + Playing <$> parseFile <*> parseDuration' + where + parseFile = "PLAY:/mnt/sata/" *> takeWhile1 (not . colon) + parseDuration' = ":DUR:" *> parseDuration + +parsePlay :: ByteString -> Parser ByteString +parsePlay f = string f <* takeWhile notNewline <* takeNewlines <* prompt + +parsePlayStatus :: Parser PlayStatus +parsePlayStatus = (parsePlayIdle <|> parsePlaying) <* takeNewlines <* prompt + +-------------------------------------------------------------------------------- +-- REC Parsers +-------------------------------------------------------------------------------- +parseRec :: Parser ByteString +parseRec = takeWhile notNewline <* takeNewlines <* prompt + +parseRecordIdle :: Parser RecordStatus +parseRecordIdle = do + void "REC:IDLE" + pure RecordIdle + +parseRecording :: Parser RecordStatus +parseRecording = + Recording <$> parseFile <*> parseDuration' + where + parseFile = "REC:/mnt/sata/" *> takeWhile1 (not . colon) + parseDuration' = ":DUR:" *> parseDuration + +parseRecordStatus :: Parser RecordStatus +parseRecordStatus = (parseRecordIdle <|> parseRecording) <* takeNewlines <* prompt + +-------------------------------------------------------------------------------- +-- TYPE Parser +-------------------------------------------------------------------------------- + +parseInfo :: Parser Info +parseInfo = Info <$> parseLabsatLines + +-------------------------------------------------------------------------------- +-- MON Parsers +-------------------------------------------------------------------------------- + +-- | Constellation parser. +-- +parseConstellation :: Parser Constellation +parseConstellation = + (string "GPS" >> pure GPS) <|> + (string "GLO" >> pure GLO) <|> + (string "BDS" >> pure BDS) <|> + (string "GAL" >> pure GAL) + +-- | Satellite CNO parser. +-- +parseSatelliteCNO :: Parser [SatelliteCNO] +parseSatelliteCNO = do + res <- option [] (commaSep takeDigits <* takeNewlines) + pure $ uncurry SatelliteCNO <$> extractSatelliteCNOPairs res + where + extractSatelliteCNOPairs :: [ByteString] -> [(ByteString, ByteString)] + extractSatelliteCNOPairs [] = [] + extractSatelliteCNOPairs [_] = error "Corrupt Satellite CNO information" + extractSatelliteCNOPairs (x:y:xs) = (x,y) : extractSatelliteCNOPairs xs + +-- | Constellation CNO parser. +-- +parseConstellationCNO :: Parser ConstellationCNO +parseConstellationCNO = + ConstellationCNO <$> + parseConstellation <* " " <*> + takeDigits <* takeNewlines <*> + parseSatelliteCNO + +-- | 'MON:LOC' parser +-- +-- | TODO handle case when record/replay is turned off and ',0.000000,,,,,' is returned +-- +parseMonLoc :: Parser Location +parseMonLoc = Location <$> double <* "," <*> parseLocation <* "," <*> parseLocation <* "," <*> parseLocation + where + parseLocation = (,) <$> double <* "," <*> parseDirection + parseDirection = takeWhile1 (inClass "MNSEW") + +-- | 'MON:SAT' parser +-- +parseMonSat :: Parser [ConstellationCNO] +parseMonSat = manyTill parseConstellationCNO prompt + +-------------------------------------------------------------------------------- +-- MUTE Parsers +-------------------------------------------------------------------------------- + +-- | 'MUTE' parser +-- +parseMute :: Parser MuteConf +parseMute = + MuteConf <$> + pure Nothing <*> + parseChannelMute "CH1" <*> + parseChannelMute "CH2" <*> + parseChannelMute "CH3" <* ok <* takeNewlines <* prompt + where + parseChannelId ch = string $ "OK:MUTE:"++ch++":" + parseChannelMute ch = option Nothing (parseChannelId ch *> (Just <$> parseYN) <* optWhitespace) + optWhitespace = option "" " \r\r\n" + +-------------------------------------------------------------------------------- +-- ATTN Parsers +-------------------------------------------------------------------------------- + +-- | 'ATTN' parser +-- +parseAttn :: Parser AttnConf +parseAttn = + AttnConf <$> + pure Nothing <*> + parseChannelAttn "CH1" <*> + parseChannelAttn "CH2" <*> + parseChannelAttn "CH3" <* ok <* takeNewlines <* prompt + where + parseChannelId ch = string $ "OK:ATTN:"++ch++":" + parseChannelAttn ch = option Nothing (parseChannelId ch *> (Just <$> signed decimal) <* " " <* takeNewlines) + +-------------------------------------------------------------------------------- +-- CONF Parsers +-------------------------------------------------------------------------------- + +-- | 'CONF:SETUP:CAN:CHX:BAUD' parser +-- +parseCANBaud :: Parser Double +parseCANBaud = "baud value is " *> double <* " " <* takeNewlines <* okPrompt + + +parseQuantization :: Parser Quantization +parseQuantization = (string "QUA-1" >> pure QUA1) <|> + (string "QUA-2" >> pure QUA2) <|> + (string "QUA-3" >> pure QUA3) + + +parseBandwidth :: Parser Bandwidth +parseBandwidth = (string "BW-10" >> pure BW_10) <|> + (string "BW-30" >> pure BW_30) <|> + (string "BW-56" >> pure BW_56) + +-- | 'CONF:CONS' parsers +-- +-- | WARNING: The output of CONF:CONS relies on a leading space in some cases +-- +-- | TODO: cleanup +parseConsPreset :: Parser ConstellationPresetConf +parseConsPreset = + ConstellationPresetConf <$> parseQua <*> parseBW <*> parsePresets <* takeNewlines <* okPrompt + where parseQua = parseQuantization <* ", " + parseBW = parseBandwidth <* ", " + parsePresets = do + void $ string "Available ch(" <* takeDigits <* string ") " + presets <- takeDigits `sepBy'` string ", " <* string " " + pure $ freqPresetLookup <$> presets + +parseConsFreq :: Parser ConstellationFreqConf +parseConsFreq = + ConstellationFreqConf <$> parseQua <*> parseBW <*> parseFreqs <* takeNewlines <* okPrompt + where optHeader = option "" ("TELNET_CONF " <* takeNewlines) + parseQua = optHeader *> " " *> parseQuantization <* ", " + parseBW = parseBandwidth <* ", " + parseFreqs = do + void $ string "Available ch(" <* takeDigits <* string ") " + scientific `sepBy'` string ", " <* string " " + + diff --git a/src/Labsat/Types.hs b/src/Labsat/Types.hs new file mode 100644 --- /dev/null +++ b/src/Labsat/Types.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Labsat.Types where + +import Data.Scientific +import Preamble + + +-- | HelpCommands: List of commands returned by 'HELP' +-- +newtype HelpCommands = + HelpCommands [ByteString] + deriving (Eq, Show) + +$(makePrisms ''HelpCommands) + + +-- | Info: List of information returned by 'TYPE' +-- +newtype Info = + Info [ByteString] + deriving (Eq, Show) + +$(makePrisms ''Info) + +-- | PlayStatus: Playback status, Idle or Playing +-- +data PlayStatus = + Playing ByteString ByteString + | PlayIdle + deriving (Eq, Show) + +$(makePrisms ''PlayStatus) + +-- | RecordStatus: Recording status, Idle or Recording +-- +data RecordStatus = + Recording ByteString ByteString + | RecordIdle + deriving (Eq, Show) + +$(makePrisms ''RecordStatus) + +-- | PlayConf: Playback configuration +-- +data PlayConf = PlayConf + { -- File to playback + _pcFile :: ByteString + -- Playback duration + , _pcFor :: Maybe Int + -- Starting position + , _pcFrom :: Maybe Int + } deriving (Eq, Show) + +$(makeLenses ''PlayConf) + +-- | RecConf: Record configuration +-- +data RecordConf = RecordConf + { -- File to record + _rcFile :: Maybe ByteString + -- Record duration + , _rcFor :: Maybe Int + } deriving (Eq, Show) + +$(makeLenses ''RecordConf) + +-- | MuteConf: Mute configuration +-- +data MuteConf = MuteConf + { -- Mute all (overrides the rest) + _mcMuteAll :: Maybe Bool + -- Mute channel 1 + , _mcMuteCh1 :: Maybe Bool + -- Mute channel 2 + , _mcMuteCh2 :: Maybe Bool + -- Mute channel 3 + , _mcMuteCh3 :: Maybe Bool + } deriving (Eq, Show) + +$(makeLenses ''MuteConf) + +-- | Attentuation configuration. +-- +data AttnConf = AttnConf + { -- Attentuation value for all channels + _acAttnAll :: Maybe Int + -- Attentuation value for channel 1 + , _acAttnCh1 :: Maybe Int + -- Attentuation value for channel 2 + , _acAttnCh2 :: Maybe Int + -- Attentuation value for channel 3 + , _acAttnCh3 :: Maybe Int + } deriving (Eq, Show) + +$(makeLenses ''AttnConf) + +-- | Media: File or Directory +-- +data Media = + File ByteString ByteString + | Dir ByteString + deriving (Eq, Show) + +$(makePrisms ''Media) + +-- | MediaList: List of files and directories +-- +newtype MediaList = + MediaList [Media] + deriving (Eq, Show) + +$(makePrisms ''MediaList) + +-- | Media type +-- +data MediaType = USB | SD | SATA + deriving (Eq, Show) + +$(makePrisms ''MediaType) + +-- | Digital Function type +data DigitalFunction = OFF | CAN1 | CAN2 | RS232 | DIGI1 | DIGI2 | OnePPS + deriving (Eq, Show) + +$(makePrisms ''DigitalFunction) + +-- | CAN Bus Channel +-- +data CANChannel = CAN_CH1 | CAN_CH2 + +$(makePrisms ''CANChannel) + +instance Show CANChannel where + show CAN_CH1 = "CH1" + show CAN_CH2 = "CH2" + +-- | Bandwidth type +-- +data Bandwidth = BW_10 | BW_30 | BW_56 + deriving (Eq) + +$(makePrisms ''Bandwidth) + +instance Show Bandwidth where + show BW_10 = "BW:10" + show BW_30 = "BW:30" + show BW_56 = "BW:56" + +-- | Quantization type +-- +data Quantization = QUA1 | QUA2 | QUA3 + deriving (Eq) + +$(makePrisms ''Quantization) + +instance Show Quantization where + show QUA1 = "QUA:1" + show QUA2 = "QUA:2" + show QUA3 = "QUA:3" + +-- | Frequency presets +-- +data FreqPreset = + Beidou1 + | Beidou2 + | Beidou3 + | Freq1191_795MHz + | Freq1233_738MHz + | Freq1567_236MHz + | Freq1580MHz + | GLONASS1 + | GLONASS2 + | GPS1 + | GPS2 + | GPS5 + | Galileo6 + | LBand + | UnknownPreset ByteString + deriving (Eq) + +$(makePrisms ''FreqPreset) + +instance Show FreqPreset where + show Beidou1 = "5" + show Beidou2 = "12" + show Beidou3 = "8" + show Freq1191_795MHz = "14" + show Freq1233_738MHz = "10" + show Freq1567_236MHz = "4" + show Freq1580MHz = "2" + show GLONASS1 = "1" + show GLONASS2 = "9" + show GPS1 = "3" + show GPS2 = "11" + show GPS5 = "13" + show Galileo6 = "7" + show LBand = "6" + show (UnknownPreset a) = show a + +freqPresetLookup :: ByteString -> FreqPreset +freqPresetLookup bs = + case bs of + "5" -> Beidou1 + "12" -> Beidou2 + "8" -> Beidou3 + "14" -> Freq1191_795MHz + "10" -> Freq1233_738MHz + "4" -> Freq1567_236MHz + "2" -> Freq1580MHz + "1" -> GLONASS1 + "9" -> GLONASS2 + "3" -> GPS1 + "11" -> GPS2 + "13" -> GPS5 + "7" -> Galileo6 + "6" -> LBand + other -> UnknownPreset other + +-- | Constellation Preset Configuration +-- +data ConstellationPresetConf = ConstellationPresetConf + { -- Signal quantization + _cpcQuantization :: Quantization + -- Bandwidth + , _cpcBandwidth :: Bandwidth + -- Frequency presets (up to three) + , _cpcFreqPresets :: [FreqPreset] + } + +$(makeLenses ''ConstellationPresetConf) + +instance Show ConstellationPresetConf where + show cpc = joinColon [quant, bandwidth, presets] + where joinColon = intercalate ":" + freqs = cpc ^. cpcFreqPresets + quant = show $ cpc ^. cpcQuantization + bandwidth = show $ cpc ^. cpcBandwidth + presets = if null freqs + then "" + else joinColon ("SETS" : map show freqs) + +-- | Constellation Frequency Configuration +-- +data ConstellationFreqConf = ConstellationFreqConf + { -- Signal quantization + _cfcQuantization :: Quantization + -- Bandwidth + , _cfcBandwidth :: Bandwidth + -- Frequencies + , _cfcFrequencies :: [Scientific] + } deriving (Eq) + +$(makeLenses ''ConstellationFreqConf) + +instance Show ConstellationFreqConf where + show cfc = joinColon [quant, bandwidth, presets] + where joinColon = intercalate ":" + freqs = cfc ^. cfcFrequencies + quant = show $ cfc ^. cfcQuantization + bandwidth = show $ cfc ^. cfcBandwidth + presets = if null freqs + then "" + else joinColon ("FREQ" : map show freqs) + +-- | Satellite navigation systems +-- +data Constellation + = BDS -- ^ Chinese BeiDou (Compass) + | GAL -- ^ European Galileo + | GLO -- ^ Russian GLONASS + | GPS -- ^ US NAVSTAR GPS + deriving (Eq, Show) + +$(makePrisms ''Constellation) + +-- | Satellite CNO: Carrier-to-noise ration for a satellite +-- +data SatelliteCNO = + SatelliteCNO ByteString ByteString + deriving (Eq, Show) + +$(makePrisms ''SatelliteCNO) + + +-- | CNO: Carrier-to-noise ratio for a constellation +-- +data ConstellationCNO = + ConstellationCNO Constellation ByteString [SatelliteCNO] + deriving (Eq, Show) + +$(makePrisms ''ConstellationCNO) + +-- | Location +-- +data Location = Location + { -- GPS Time + _time :: Double + -- Elevation (meters, direction) + , _height :: (Double, ByteString) + -- Lattitude (degrees, direction) + , _lattitude :: (Double, ByteString) + -- Longitude (degrees, direction) + , _longitude :: (Double, ByteString) + } deriving (Eq, Show) + +$(makeLenses ''Location) + diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +import Preamble +import qualified Test.Labsat.Parser as Parser +import Test.Tasty + +tests :: TestTree +tests = + testGroup "Tests" + [ Parser.tests + ] + +main :: IO () +main = defaultMain tests diff --git a/test/Test/Labsat/Parser.hs b/test/Test/Labsat/Parser.hs new file mode 100644 --- /dev/null +++ b/test/Test/Labsat/Parser.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Labsat.Parser + ( tests + ) where + +import Data.Attoparsec.ByteString +import Data.ByteString +import Labsat.Parser +import Labsat.Types +import Preamble +import Test.Tasty +import Test.Tasty.HUnit + +parser :: (Eq a, Show a) => Parser a -> ByteString -> Either String a -> Assertion +parser p s r = parseOnly p s @?= r + +-------------------------------------------------------------------------------- +-- HELP Parsers +-------------------------------------------------------------------------------- +helpOutput :: ByteString +helpOutput = "Current commands are : \r\r\n\r\r\nHELP\r\r\nTYPE\r\r\nFIND\r\r\nMON\r\r\nPLAY\r\r\nREC\r\r\nATTN\r\r\nCONF\r\r\nMEDIA\r\r\nMUTE\r\r\n\r\r\n\r\r\nLABSAT_V3 >" + +helpResult :: HelpCommands +helpResult = HelpCommands ["HELP","TYPE","FIND","MON","PLAY","REC","ATTN","CONF","MEDIA","MUTE"] + +testHelp :: TestTree +testHelp = + testGroup "Test help parser" + [ testCase "Help without colors" $ parser parseHelp helpOutput $ Right helpResult + ] + +-------------------------------------------------------------------------------- +-- MEDIA Parsers +-------------------------------------------------------------------------------- +mediaListOutput :: ByteString +mediaListOutput = "ABC \ESC[40G 00:00:00\r\r\nASDF\r\r\nFile_001 \ESC[40G 00:05:40\r\r\nFile_002 \ESC[40G 00:21:17\r\r\nLabSat 3 Wideband Demo SSD files\r\r\n\r\r\nLABSAT_V3 >" + +mediaListResult :: MediaList +mediaListResult = MediaList [File "ABC" "00:00:00",Dir "ASDF",File "File_001" "00:05:40",File "File_002" "00:21:17",Dir "LabSat 3 Wideband Demo SSD files"] + +testMedia :: TestTree +testMedia = + testGroup "Test media parsers" + [ testCase "Media list" $ parser parseMediaList mediaListOutput $ Right mediaListResult + ] + +-------------------------------------------------------------------------------- +-- PLAY Parsers +-------------------------------------------------------------------------------- +playFileOutput :: ByteString +playFileOutput = "File_001\r\r\n\r\r\nLABSAT_V3 >" + +statusPlayingOutput :: ByteString +statusPlayingOutput = "PLAY:/mnt/sata/File_001:DUR:00:00:20\r\r\n\r\r\nLABSAT_V3 >" + +statusPlayingResult :: PlayStatus +statusPlayingResult = Playing "File_001" "00:00:20" + +statusIdleOutput :: ByteString +statusIdleOutput = "PLAY:IDLE\r\r\n\r\r\nLABSAT_V3 >" + +testPlay :: TestTree +testPlay = + testGroup "Test play parsers" + [ testCase "Play file" $ parser (parsePlay "File_001") playFileOutput $ Right "File_001" + , testCase "Status playing" $ parser parsePlayStatus statusPlayingOutput $ Right statusPlayingResult + , testCase "Status idle" $ parser parsePlayStatus statusIdleOutput $ Right PlayIdle + ] + +-------------------------------------------------------------------------------- +-- REC Parsers +-------------------------------------------------------------------------------- +statusRecordingOutput :: ByteString +statusRecordingOutput = "REC:/mnt/sata/File_004:DUR:00:00:08\r\r\n\r\r\nLABSAT_V3 >" + +statusRecordingResult :: RecordStatus +statusRecordingResult = Recording "File_004" "00:00:08" + +statusRecordIdleOutput :: ByteString +statusRecordIdleOutput = "REC:IDLE\r\r\n\r\r\nLABSAT_V3 >" + +testRecord :: TestTree +testRecord = + testGroup "Test record parsers" + [ testCase "Recordfile" $ parser parseRec playFileOutput $ Right "File_001" + , testCase "Status playing" $ parser parseRecordStatus statusRecordingOutput $ Right statusRecordingResult + , testCase "Status idle" $ parser parseRecordStatus statusRecordIdleOutput $ Right RecordIdle + ] + +-------------------------------------------------------------------------------- +-- TYPE Parser +-------------------------------------------------------------------------------- +typeOutput :: ByteString +typeOutput = "Labsat Wideband\r\nSerial 57082 \r\nFirmware 1.0.260\r\nFPGA 33\r\nIP 10.1.22.44\r\nBattery not connected\r\nTCXO-0x7b7f\r\n\r\r\n\r\r\nLABSAT_V3 >" + +typeResult :: Info +typeResult = Info ["Labsat Wideband","Serial 57082 ","Firmware 1.0.260","FPGA 33","IP 10.1.22.44","Battery not connected","TCXO-0x7b7f"] + +testType :: TestTree +testType = + testGroup "Test type parser" + [ testCase "Type command" $ parser parseInfo typeOutput $ Right typeResult + ] + +-------------------------------------------------------------------------------- +-- MON Parsers +-------------------------------------------------------------------------------- + +monSatOutput :: ByteString +monSatOutput = "GPS 9\r\r\n05,42,07,52,08,43,09,52,16,35,23,47,27,43,28,42,30,49\r\r\n\r\r\nGLO 10\r\r\n01,50,02,52,03,36,08,37,10,36,11,50,12,50,13,32,20,31,21,40\r\r\n\r\r\nBDS 0\r\r\n\r\r\nGAL 4\r\r\n01,44,04,42,19,44,20,36\r\r\n\r\r\nLABSAT_V3 >" + +monSatResult :: [ConstellationCNO] +monSatResult = [ConstellationCNO GPS "9" [SatelliteCNO "05" "42",SatelliteCNO "07" "52",SatelliteCNO "08" "43",SatelliteCNO "09" "52",SatelliteCNO "16" "35",SatelliteCNO "23" "47",SatelliteCNO "27" "43",SatelliteCNO "28" "42",SatelliteCNO "30" "49"],ConstellationCNO GLO "10" [SatelliteCNO "01" "50",SatelliteCNO "02" "52",SatelliteCNO "03" "36",SatelliteCNO "08" "37",SatelliteCNO "10" "36",SatelliteCNO "11" "50",SatelliteCNO "12" "50",SatelliteCNO "13" "32",SatelliteCNO "20" "31",SatelliteCNO "21" "40"],ConstellationCNO BDS "0" [],ConstellationCNO GAL "4" [SatelliteCNO "01" "44",SatelliteCNO "04" "42",SatelliteCNO "19" "44",SatelliteCNO "20" "36"]] + +monLocOutput :: ByteString +monLocOutput = "123456.00,-5.800000,M,1234.12345,N,54321.54321,W\r\r\n\r\r\nLABSAT_V3 >" + +monLocResult :: Location +monLocResult = Location {_time = 123456.0, _height = (-5.8,"M"), _lattitude = (1234.12345,"N"), _longitude = (54321.54321,"W")} + +testMon :: TestTree +testMon = + testGroup "Test MON parsers" + [ testCase "Test MON:SAT" $ parser parseMonSat monSatOutput $ Right monSatResult + , testCase "Test MON:LOC" $ parser parseMonLoc monLocOutput $ Right monLocResult + ] + +-------------------------------------------------------------------------------- +-- ATTN Parsers +-------------------------------------------------------------------------------- + +attnOutput1 :: ByteString +attnOutput1 = "OK:ATTN:CH1:0 \r\r\nOK:ATTN:CH2:0 \r\r\nOK:ATTN:CH3:0 \r\r\nOK\r\r\n\r\r\nLABSAT_V3 >" + +attnOutput2 :: ByteString +attnOutput2 = "OK:ATTN:CH1:10 \r\r\nOK:ATTN:CH3:10 \r\r\nOK\r\r\n\r\r\nLABSAT_V3 >" + +attnResult1 :: AttnConf +attnResult1 = AttnConf {_acAttnAll = Nothing, _acAttnCh1 = Just 0, _acAttnCh2 = Just 0, _acAttnCh3 = Just 0} + +attnResult2 :: AttnConf +attnResult2 = AttnConf {_acAttnAll = Nothing, _acAttnCh1 = Just 10, _acAttnCh2 = Nothing, _acAttnCh3 = Just 10} + +testAttn :: TestTree +testAttn = + testGroup "Test ATTN parsers" + [ testCase "Test ATTN:0" $ parser parseAttn attnOutput1 $ Right attnResult1 + , testCase "Test ATTN:CH1:10:CH3:10" $ parser parseAttn attnOutput2 $ Right attnResult2 + ] + +-------------------------------------------------------------------------------- +-- CONF Parsers +-------------------------------------------------------------------------------- + +canBaudOutput :: ByteString +canBaudOutput = "baud value is 500000.000000 \r\r\nOK\r\r\n\r\r\nLABSAT_V3 >" + +canBaudResult :: Double +canBaudResult = 500000.0 + +consFreqOutput :: ByteString +consFreqOutput = "TELNET_CONF \r\r\n QUA-1, BW-10, Available ch(1) 1575420000, 1207140014, 1268520019 \r\r\nOK\r\r\n\r\r\nLABSAT_V3 >" + +consFreqResult :: ConstellationFreqConf +consFreqResult = ConstellationFreqConf { + _cfcQuantization = QUA1, + _cfcBandwidth = BW_10, + _cfcFrequencies = [1.57542e9,1.207140014e9,1.268520019e9]} + +testConf :: TestTree +testConf = + testGroup "Test CONF parsers" + [ testCase "Test CONF:SETUP:CAN:CH1:BAUD:500000" $ parser parseCANBaud canBaudOutput $ Right canBaudResult + , testCase "Test CONF:CONS:QUA:1:BW:10:FREQ:1575420000" $ parser parseConsFreq consFreqOutput $ Right consFreqResult + ] + +tests :: TestTree +tests = + testGroup "LabSat parser tests" + [ testHelp + , testMedia + , testPlay + , testRecord + , testType + , testMon + , testAttn + , testConf + ]