diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Jacek Galowicz (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,24 @@ +# hamtsolo + +[![Build Status](https://travis-ci.org/tfc/hamtsolo.svg?branch=master)](https://travis-ci.org/tfc/hamtsolo) + +Connect to an Intel computer with enabled AMT and establish a serial-over-lan (SOL) connection. + +Does not support encryption. (Use Intel ME in small business mode.) + +## Usage + +```bash +hamtsolo - An Intel AMT Serial-Over-LAN (SOL) client + +Usage: hamtsolo [-u|--user ] [-p|--pass ] [--port ] + hamtsolo lets you connect to Intel computers with enabled AMT and establish a + serial-over-lan (SOL) connection. + +Available options: + -h,--help Show this help text + -u,--user Authentication user name (default: "admin") + -p,--pass Authentication password (default: "Password123!") + --port TCP connection port (default: 16994) + AMT host to connect to +``` 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/hamtsolo.cabal b/hamtsolo.cabal new file mode 100644 --- /dev/null +++ b/hamtsolo.cabal @@ -0,0 +1,40 @@ +name: hamtsolo +version: 1.0.0 +synopsis: Intel AMT serial-over-lan (SOL) client +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 +maintainer: jacek@galowicz.de +copyright: 2017 Jacek Galowicz +category: Network +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +executable hamtsolo + hs-source-dirs: src + main-is: HamtSolo.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 + build-depends: async == 2.1.* + , attoparsec == 0.13.* + , attoparsec-binary == 0.2.* + , base == 4.9.* + , binary == 0.8.* + , bytestring == 0.10.* + , conduit == 1.2.* + , conduit-combinators == 1.1.* + , conduit-extra == 1.1.* + , exceptions == 0.8.* + , optparse-applicative == 0.13.* + , resourcet == 1.1.* + , stm-conduit == 3.0.* + , unix == 2.7.* + , word8 == 0.1.* + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/tfc/hamtsolo diff --git a/src/HamtSolo.hs b/src/HamtSolo.hs new file mode 100644 --- /dev/null +++ b/src/HamtSolo.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +import Control.Exception (Exception, bracket, try) +import Control.Monad (unless, when) +import Control.Monad.Catch (throwM) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (runResourceT) +import Data.Attoparsec.Binary (anyWord16le) +import qualified Data.Attoparsec.ByteString as A +import Data.Binary (Word16, Word8, encode) +import Data.Bits (testBit) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B2 +import Data.ByteString.Lazy (toStrict) +import Data.Conduit +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.Maybe (fromJust, isJust) +import Data.Monoid ((<>)) +import Data.Typeable +import GHC.IO.Exception (IOException) +import qualified Options.Applicative as O +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) +instance Exception SolException + +data SolPacket = + HeartBeat Int + | SolData ByteString + | SolControl { + ctrlRTS :: Bool, + ctrlDTR :: Bool, + ctrlBreak :: Bool, + statusTxOverflow :: Bool, + statusLoopback :: Bool, + statusPower :: Bool, + statusRxFlushTO :: Bool, + statusTestMode :: Bool + } + | UserMsgToHost ByteString + -- Use bytestring instead of Word8 because maybe we want to send + -- line buffered strings in the future. + | UserQuit + deriving (Show) + +solParser :: A.Parser SolPacket +solParser = A.choice [ + do { A.word8 0x2b; A.take 3; n <- anyWord16le; A.take 2; return $ HeartBeat $ fromIntegral n }, + do { A.word8 0x2a; A.take 7; n <- anyWord16le; s <- A.take $ fromIntegral n; return $ SolData s }, + do { A.word8 0x29; A.take 7; control <- A.anyWord8; status <- A.anyWord8; + return $ SolControl (testBit control 0) (testBit control 1) (testBit control 2) + (testBit status 0) (testBit status 1) (testBit status 2) + (testBit status 3) (testBit status 4) + } + ] + +userParser :: A.Parser SolPacket +userParser = A.choice [ + A.word8 0x1d *> return UserQuit, + UserMsgToHost . B.singleton <$> A.anyWord8 + ] + +authMsg :: ByteString -> ByteString -> ByteString +authMsg u p = let + lu = fromIntegral (B.length u) :: Word8 + lp = fromIntegral (B.length p) :: Word8 + lg = 2 + lu + lp + in + B.concat [ B.pack [0x13, 0, 0, 0, 1, lg, 0, 0, 0, lu], u, B.pack [lp], p ] + +startSolMsg :: ByteString +startSolMsg = let + maxTxBuffer = 1000 :: Word16 + txBufferTimeout = 100 :: Word16 + txOverflowTimeout = 0 :: Word16 + hostSessionRxTimeout = 10000 :: Word16 + hostFifoRxFlushTimeout = 0 :: Word16 + heartbeatInterval = 5000 :: Word16 + in + B.concat [ B.pack [0x20, 0, 0, 0, 0, 0, 0, 0], + B.concat $ map (B.reverse . toStrict . encode) + [maxTxBuffer, txBufferTimeout, txOverflowTimeout, hostSessionRxTimeout, hostFifoRxFlushTimeout, heartbeatInterval], + B.pack [0, 0, 0, 0]] + +sayHello :: Conduit ByteString IO ByteString +sayHello = yield $ B.pack [0x10, 0x00, 0x00, 0x00, 0x53, 0x4f, 0x4c, 0x20] + +okPacket :: Word8 -> Int -> A.Parser Bool +okPacket x n = do { A.word8 x; bad <- A.anyWord8; A.take (n - 2); return $ bad == 0 } + +userMsgPacket :: ByteString -> ByteString +-- TODO: send word16 with actual length instead of [1, 0] +userMsgPacket bs = let + 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 errStr p = do + packetGood <- sinkParser p + unless packetGood $ throwM $ SolException errStr + +reactPrologue :: String -> String -> Conduit ByteString IO ByteString +reactPrologue user pass = do + acceptPacketOrThrow "Server does not accept redirection request." $ okPacket 0x11 13 + yield $ authMsg (B2.pack user) (B2.pack pass) + + acceptPacketOrThrow "Server does not accept authentication." $ okPacket 0x14 9 + yield startSolMsg + + acceptPacketOrThrow "Authenticated, but Server refuses SOL." $ okPacket 0x21 23 + +printInfo :: String -> IO () +printInfo = hPutStrLn stderr + +reactSolMode :: Conduit SolPacket IO ByteString +reactSolMode = awaitForever $ \x -> + case x of + HeartBeat n -> yield $ B.pack [0x2b, 0, 0, 0, 2, 0, 0, 0] + SolData s -> liftIO $ B.putStr s + SolControl rts dtr brk txOF loopB power rxFlTO testMode -> liftIO $ do + when rts $ printInfo "SOL: RTS asserted on serial" + when dtr $ printInfo "SOL: DTR asserted on serial" + 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." + UserMsgToHost m -> yield $ userMsgPacket m + +withTerminalSettings :: IO r -> IO r +withTerminalSettings runStuff = let + setStdinAttrs a = T.setTerminalAttributes stdInput a T.WhenFlushed + in + bracket + (do + eOldSettings :: Either IOException T.TerminalAttributes <- try $ T.getTerminalAttributes stdInput + case eOldSettings of + Left _ -> return Nothing + Right oldSettings -> do + let newSettings = flip T.withMinInput 1 + $ flip T.withTime 0 + $ foldr id oldSettings $ flip T.withoutMode + <$> [T.KeyboardInterrupts, T.EnableEcho, T.ProcessInput] + + setStdinAttrs newSettings + return $ Just oldSettings + ) + (mapM_ setStdinAttrs) + (const runStuff) + +data CLArguments = CLArguments { user :: String, pass :: String, port :: Int, host :: String } + +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) + ( O.fullDesc + <> O.progDesc "hamtsolo lets you connect to Intel computers with enabled \ + \AMT and establish a serial-over-lan (SOL) connection." + <> O.header "hamtsolo - An Intel AMT Serial-Over-LAN (SOL) client" ) + 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) + + runResourceT $ do + sources <- TMC.mergeSources [sckIn, kbdIn] 2 + sources =$= awaitForever (yield . snd) $$ transPipe liftIO (reactSolMode =$= appSink server)