hamtsolo 1.0.2 → 1.0.3
raw patch · 2 files changed
+85/−37 lines, 2 filesdep +gitrevdep −word8
Dependencies added: gitrev
Dependencies removed: word8
Files
- hamtsolo.cabal +4/−4
- src/HamtSolo.hs +81/−33
hamtsolo.cabal view
@@ -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
src/HamtSolo.hs view
@@ -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 "<user>" <>+ O.help "Authentication user name" <> O.showDefault)+ <*> O.option O.str (O.short 'p' <> O.long "pass" <> O.value "Password123!" <> O.metavar "<password>" <>+ O.help "Authentication password" <> O.showDefault)+ <*> O.option O.auto (O.long "port" <> O.value 16994 <> O.metavar "<port>" <>+ O.help "TCP connection port" <> O.showDefault)+ <*> O.argument O.str (O.metavar "<host>" <> 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 "<user>" <>- O.help "Authentication user name" <> O.showDefault)- <*> O.option O.str ( O.short 'p' <> O.long "pass" <> O.value "Password123!" <> O.metavar "<password>" <>- O.help "Authentication password" <> O.showDefault)- <*> O.option O.auto ( O.long "port" <> O.value 16994 <> O.metavar "<port>" <>- O.help "TCP connection port" <> O.showDefault)- <*> O.argument O.str ( O.metavar "<host>" <> 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