diff --git a/hamtsolo.cabal b/hamtsolo.cabal --- a/hamtsolo.cabal +++ b/hamtsolo.cabal @@ -1,12 +1,12 @@ name: hamtsolo -version: 1.0.2 +version: 1.0.3 synopsis: Intel AMT serial-over-lan (SOL) client -description: hamtsolo lets you connect to Intel computers with enabled +description: hamtsolo lets you connect to Intel computers with enabled AMT and establish a serial-over-lan (SOL) connection. homepage: https://github.com/tfc/hamtsolo#readme license: BSD3 license-file: LICENSE -author: Jacek Galowicz +author: Jacek Galowicz maintainer: jacek@galowicz.de copyright: 2017 Jacek Galowicz category: Network @@ -28,11 +28,11 @@ , conduit-combinators >= 1.1 , conduit-extra >= 1.2 , exceptions >= 0.8 + , gitrev >= 1.3 , optparse-applicative >= 0.14 , resourcet >= 1.1 , stm-conduit >= 3.0 , unix >= 2.7 - , word8 >= 0.1 default-language: Haskell2010 source-repository head diff --git a/src/HamtSolo.hs b/src/HamtSolo.hs --- a/src/HamtSolo.hs +++ b/src/HamtSolo.hs @@ -1,6 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +import Control.Applicative ((<|>)) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async import Control.Exception (Exception, bracket, try) import Control.Monad (unless, when) import Control.Monad.Catch (throwM) @@ -15,23 +20,28 @@ import qualified Data.ByteString.Char8 as B2 import Data.ByteString.Lazy (toStrict) import Data.Conduit +import qualified Data.Conduit as CI import Data.Conduit.Attoparsec (conduitParser, sinkParser) import qualified Data.Conduit.Combinators as CC -import qualified Data.Conduit.Internal as CI import Data.Conduit.Network import qualified Data.Conduit.TMChan as TMC +import Data.IORef import Data.Maybe (fromJust, isJust) import Data.Monoid ((<>)) import Data.Typeable +import Development.GitRev import GHC.IO.Exception (IOException) import qualified Options.Applicative as O +import System.Exit (die, exitSuccess) import System.IO (BufferMode (..), hPutStrLn, hSetBuffering, stderr, stdin, stdout) import System.Posix.IO (stdInput) import qualified System.Posix.Terminal as T -data SolException = SolException String deriving (Show, Typeable) +data SolException = UserQuitException + | SolException String + deriving (Show) instance Exception SolException data SolPacket = @@ -92,7 +102,7 @@ [maxTxBuffer, txBufferTimeout, txOverflowTimeout, hostSessionRxTimeout, hostFifoRxFlushTimeout, heartbeatInterval], B.pack [0, 0, 0, 0]] -sayHello :: Conduit ByteString IO ByteString +sayHello :: ConduitT ByteString ByteString IO () sayHello = yield $ B.pack [0x10, 0x00, 0x00, 0x00, 0x53, 0x4f, 0x4c, 0x20] okPacket :: Word8 -> Int -> A.Parser Bool @@ -104,12 +114,12 @@ patchedMsg = B.map (\c -> if c == 0xa then 0xd else c) bs -- transform LF to CR in B.concat [ B.pack [0x28, 0, 0, 0, 0, 0, 0, 0], B.pack [1, 0], patchedMsg] -acceptPacketOrThrow :: String -> A.Parser Bool -> Conduit ByteString IO ByteString +acceptPacketOrThrow :: String -> A.Parser Bool -> ConduitT ByteString ByteString IO () acceptPacketOrThrow errStr p = do packetGood <- sinkParser p unless packetGood $ throwM $ SolException errStr -reactPrologue :: String -> String -> Conduit ByteString IO ByteString +reactPrologue :: String -> String -> ConduitT ByteString ByteString IO () reactPrologue user pass = do acceptPacketOrThrow "Server does not accept redirection request." $ okPacket 0x11 13 yield $ authMsg (B2.pack user) (B2.pack pass) @@ -122,8 +132,9 @@ printInfo :: String -> IO () printInfo = hPutStrLn stderr -reactSolMode :: Conduit SolPacket IO ByteString -reactSolMode = awaitForever $ \x -> +reactSolMode :: IORef Int -> ConduitT SolPacket ByteString IO () +reactSolMode watchDog = awaitForever $ \x -> do + liftIO $ writeIORef watchDog 20 case x of HeartBeat n -> yield $ B.pack [0x2b, 0, 0, 0, 2, 0, 0, 0] SolData s -> liftIO $ B.putStr s @@ -133,8 +144,7 @@ when brk $ printInfo "SOL: BRK asserted on serial" when power $ printInfo "SOL: power state change" when loopB $ printInfo "SOL: loopback mode activated" - return () - UserQuit -> throwM $ SolException "Seen ^]. Quitting app." + UserQuit -> throwM UserQuitException UserMsgToHost m -> yield $ userMsgPacket m withTerminalSettings :: IO r -> IO r @@ -158,19 +168,66 @@ (mapM_ setStdinAttrs) (const runStuff) -data CLArguments = CLArguments { user :: String, pass :: String, port :: Int, host :: String } +withTimeout :: Int -> (IORef Int -> IO a) -> IO () +withTimeout initialTimeout userF = do + counter <- newIORef initialTimeout + networkThread <- async (userF counter) + f counter networkThread + where + f c t = poll t >>= \case + Nothing -> do + threadDelay (10^6 :: Int) + c' <- atomicModifyIORef' c (\x -> (x-1, x-1)) + if c' < 0 + then cancel t >> die "Connection timeout" + else f c t + Just (Left e) -> die $ show e + Just (Right _) -> exitSuccess + +runAmtHandling :: ClientSettings -> String -> String -> IORef Int -> IO () +runAmtHandling settings user pass watchDog = + runTCPClient settings $ \server -> do + liftIO $ printInfo "Connected. Authenticating." + (fromClient, ()) <- appSource server $$+ sayHello .| appSink server + liftIO $ printInfo "Authenticated. SOL active." + withTerminalSettings $ do + (fromClient2 :: CI.SealedConduitT () ByteString IO (), _) <- fromClient $$++ (reactPrologue user pass .| appSink server) + let clientSource = CI.unsealConduitT fromClient2 + + let sckIn = transPipe liftIO (clientSource .| conduitParser solParser) + let kbdIn = transPipe liftIO (CC.stdin .| conduitParser userParser) + + runResourceT $ do + sources <- TMC.mergeSources [sckIn, kbdIn] 2 + runConduit $ + sources .| awaitForever (yield . snd) + .| transPipe liftIO (reactSolMode watchDog .| appSink server) + +versionString :: String +versionString = "hamtsolo " ++ $(gitHash) ++ ['+' | $(gitDirty)] ++ " (" ++ $(gitCommitDate) ++ ")" + +data CliArguments = CliArguments { + user :: String, + pass :: String, + port :: Int, + host :: String +} + +cliArgParser :: O.Parser CliArguments +cliArgParser = CliArguments + <$> O.option O.str (O.short 'u' <> O.long "user" <> O.value "admin" <> O.metavar "" <> + O.help "Authentication user name" <> O.showDefault) + <*> O.option O.str (O.short 'p' <> O.long "pass" <> O.value "Password123!" <> O.metavar "" <> + O.help "Authentication password" <> O.showDefault) + <*> O.option O.auto (O.long "port" <> O.value 16994 <> O.metavar "" <> + O.help "TCP connection port" <> O.showDefault) + <*> O.argument O.str (O.metavar "" <> O.help "AMT host to connect to") + main :: IO () main = let - parser = CLArguments - <$> O.option O.str ( O.short 'u' <> O.long "user" <> O.value "admin" <> O.metavar "" <> - O.help "Authentication user name" <> O.showDefault) - <*> O.option O.str ( O.short 'p' <> O.long "pass" <> O.value "Password123!" <> O.metavar "" <> - O.help "Authentication password" <> O.showDefault) - <*> O.option O.auto ( O.long "port" <> O.value 16994 <> O.metavar "" <> - O.help "TCP connection port" <> O.showDefault) - <*> O.argument O.str ( O.metavar "" <> O.help "AMT host to connect to") - opts = O.info (O.helper <*> parser) + parser = O.flag' Nothing (O.long "version" <> O.hidden) <|> (Just <$> cliArgParser) + opts = O.info (O.helper <*> parser) ( O.fullDesc <> O.progDesc "hamtsolo lets you connect to Intel computers with enabled \ \AMT and establish a serial-over-lan (SOL) connection." @@ -178,18 +235,9 @@ in do hSetBuffering stdin NoBuffering hSetBuffering stdout NoBuffering - (CLArguments user pass port host) <- O.execParser opts - runTCPClient (clientSettings port $ B2.pack host) $ \server -> do - liftIO $ printInfo "Connected. Authenticating." - (fromClient, ()) <- appSource server $$+ sayHello =$ appSink server - liftIO $ printInfo "Authenticated. SOL active." - withTerminalSettings $ do - (fromClient2, ()) <- fromClient $$++ reactPrologue user pass =$ appSink server - (clientSource, clientFinalizer) <- CI.unwrapResumable fromClient2 - - let sckIn = transPipe liftIO (clientSource =$= conduitParser solParser) - let kbdIn = transPipe liftIO (CC.stdin =$= conduitParser userParser) + mArguments <- O.execParser opts - runResourceT $ do - sources <- TMC.mergeSources [sckIn, kbdIn] 2 - sources =$= awaitForever (yield . snd) $$ transPipe liftIO (reactSolMode =$= appSink server) + case mArguments of + Nothing -> putStrLn versionString >> exitSuccess + Just (CliArguments user pass port host) -> + withTimeout 20 $ runAmtHandling (clientSettings port $ B2.pack host) user pass