App.hs

-- | Description: a file transfer monad transformer
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Transit.Internal.App
  ( Env(..)
  , prepareAppEnv
  , app
  , runApp
  )
where

import Protolude

import qualified Data.Text as Text
import qualified Data.Text.IO as TIO
import qualified MagicWormhole
import qualified System.Console.Haskeline as H
import qualified System.Console.Haskeline.Completion as HC
import qualified Crypto.Spake2 as Spake2

import System.IO.Error (IOError)
import System.Random (randomR, getStdGen)
import Data.String (String)
import Control.Monad.Trans.Except (ExceptT(..))
import Control.Monad.Except (liftEither)

import Transit.Internal.Conf (Options(..), Command(..))
import Transit.Internal.Errors (Error(..), CommunicationError(..))
import Transit.Internal.FileTransfer(MessageType(..), sendFile, receiveFile)
import Transit.Internal.Peer (sendOffer, receiveOffer, receiveMessageAck, sendMessageAck, decodeTransitMsg)
import Paths_hwormhole

type Password = ByteString

-- | Magic Wormhole transit app environment
data Env
  = Env { appID :: MagicWormhole.AppID
        -- ^ Application specific ID
        , side :: MagicWormhole.Side
        -- ^ random 5-byte bytestring
        , config :: Options
        -- ^ configuration like relay and transit url
        , wordList :: [(Text, Text)]
        -- ^ pass code word list (list of pair of words)
        }

-- | genWordlist would produce a list of the form
--   [ ("aardwark", "adroitness"),
--     ("absurd", "adviser"),
--     ....
--     ("zulu", "yucatan") ]
genWordList :: FilePath -> IO [(Text, Text)]
genWordList wordlistFile = do
  file <- TIO.readFile wordlistFile
  let contents = map toWordPair $ Text.lines file
  return contents
    where
      toWordPair :: Text -> (Text, Text)
      toWordPair line =
        let ws = map Text.toLower $ Text.words line
            Just firstWord = atMay ws 1
            Just sndWord = atMay ws 2
        in (firstWord, sndWord)


-- | Create an 'Env', given the AppID, wordlist file and 'Options'
prepareAppEnv :: Text -> FilePath -> Options -> IO Env
prepareAppEnv appid wordlistPath options = do
  side' <- MagicWormhole.generateSide
  wordlist <- genWordList =<< getDataFileName wordlistPath
  let appID' = MagicWormhole.AppID appid
  return $ Env appID' side' options wordlist

allocatePassword :: [(Text, Text)] -> IO Text
allocatePassword wordlist = do
  g <- getStdGen
  let (r1, g') = randomR (0, 255) g
      (r2, _) = randomR (0, 255) g'
      Just evenW = fst <$> atMay wordlist r2
      Just oddW = snd <$> atMay wordlist r1
  return $ Text.concat [oddW, "-", evenW]

genPasscodes :: [Text] -> [(Text, Text)] -> [Text]
genPasscodes nameplates wordpairs =
  let evens = map fst wordpairs
      odds = map snd wordpairs
      wordCombos = [ o <> "-" <> e | o <- odds, e <- evens ]
  in
    [ n <> "-" <> hiphenWord | n <- nameplates, hiphenWord <- wordCombos ]

printSendHelpText :: Text -> IO ()
printSendHelpText passcode = do
  TIO.putStrLn $  "Wormhole code is: " <> passcode
  TIO.putStrLn "On the other computer, please run:"
  TIO.putStrLn ""
  TIO.putStrLn $ "wormhole receive " <> passcode

completeWord :: MonadIO m => [Text] -> HC.CompletionFunc m
completeWord wordlist = HC.completeWord Nothing "" completionFunc
  where
    completionFunc :: Monad m => String -> m [HC.Completion]
    completionFunc word = do
      let completions = filter (toS word `Text.isPrefixOf`) wordlist
      return $ map (HC.simpleCompletion . toS) completions

-- | Take an input code from the user with code completion.
-- In order for the code completion to work, we need to find
-- the possible open nameplates, the possible words and then
-- do the completion as the user types the code.
-- TODO: This function does too much. Perfect target for refactoring.
getCode :: MagicWormhole.Session -> [(Text, Text)] -> IO Text
getCode session wordlist = do
  nameplates <- MagicWormhole.list session
  let ns = [ n | MagicWormhole.Nameplate n <- nameplates ]
  putText "Enter the receive wormhole code: "
  H.runInputT (settings (genPasscodes ns wordlist)) getInput
  where
    settings :: MonadIO m => [Text] -> H.Settings m
    settings possibleWords = H.Settings
      { H.complete = completeWord possibleWords
      , H.historyFile = Nothing
      , H.autoAddHistory = False
      }
    getInput :: H.InputT IO Text
    getInput = do
      minput <- H.getInputLine ""
      case minput of
        Nothing -> return ""
        Just input -> return (toS input)

-- | App Monad Transformer that reads the configuration from 'Env', runs
-- a computation over the IO Monad and returns either the value 'a' or 'Error'
newtype App a = App {
  getApp :: ReaderT Env (ExceptT Error IO) a
  } deriving (Functor, Applicative, Monad, MonadIO, MonadReader Env, MonadError Error)

-- | run the App Monad Transformer
runApp :: App a -> Env -> IO (Either Error a)
runApp appM env = runExceptT (runReaderT (getApp appM) env)

-- | Given the magic-wormhole session, appid, password, a function to print a helpful message
-- on the command the receiver needs to type (simplest would be just a `putStrLn`) and the
-- path on the disk of the sender of the file that needs to be sent, `sendFile` sends it via
-- the wormhole securely. The receiver, on successfully receiving the file, would compute
-- a sha256 sum of the encrypted file and sends it across to the sender, along with an
-- acknowledgement, which the sender can verify.
send :: MagicWormhole.Session -> Password -> MessageType -> App ()
send session password tfd = do
  env <- ask
  -- first establish a wormhole session with the receiver and
  -- then talk the filetransfer protocol over it as follows.
  let options = config env
  let appid = appID env
  let transitserver = transitUrl options
  nameplate <- liftIO $ MagicWormhole.allocate session
  mailbox <- liftIO $ MagicWormhole.claim session nameplate
  peer <- liftIO $ MagicWormhole.open session mailbox  -- XXX: We should run `close` in the case of exceptions?
  let (MagicWormhole.Nameplate n) = nameplate
  liftIO $ printSendHelpText $ toS n <> "-" <> toS password
  result <- liftIO $ MagicWormhole.withEncryptedConnection peer (Spake2.makePassword (toS n <> "-" <> password))
    (\conn ->
        case tfd of
          TMsg msg -> do
            let offer = MagicWormhole.Message msg
            sendOffer conn offer
            -- wait for "answer" message with "message_ack" key
            first NetworkError <$> receiveMessageAck conn
          TFile filepath ->
            sendFile conn transitserver appid filepath
    )
  liftEither result

-- | receive a text message or file from the wormhole peer.
receive :: MagicWormhole.Session -> Text -> App ()
receive session code = do
  env <- ask
  -- establish the connection
  let options = config env
  let appid = appID env
  let transitserver = transitUrl options
  let codeSplit = Text.split (=='-') code
  let (Just nameplate) = headMay codeSplit
  mailbox <- liftIO $ MagicWormhole.claim session (MagicWormhole.Nameplate nameplate)
  peer <- liftIO $ MagicWormhole.open session mailbox
  result <- liftIO $ MagicWormhole.withEncryptedConnection peer (Spake2.makePassword (toS (Text.strip code)))
    (\conn -> do
        -- unfortunately, the receiver has no idea which message to expect.
        -- If the sender is only sending a text message, it gets an offer first.
        -- if the sender is sending a file/directory, then transit comes first
        -- and then offer comes in. `Transit.receiveOffer' will attempt to interpret
        -- the bytestring as an offer message. If that fails, it passes the raw bytestring
        -- as a Left value so that we can try to decode it as a TransitMsg.
        someOffer <- receiveOffer conn
        case someOffer of
          Right (MagicWormhole.Message message) -> do
            TIO.putStrLn message
            result <- try (sendMessageAck conn "ok") :: IO (Either IOError ())
            return $ bimap (const (NetworkError (ConnectionError "sending the ack message failed"))) identity result
          Right (MagicWormhole.File _ _) -> do
            sendMessageAck conn "not_ok"
            return $ Left (NetworkError (ConnectionError "did not expect a file offer"))
          Right MagicWormhole.Directory {} ->
            return $ Left (NetworkError (UnknownPeerMessage "directory offer is not supported"))
          -- ok, we received the Transit Message, send back a transit message
          Left received ->
            case decodeTransitMsg (toS received) of
              Left e -> return $ Left (NetworkError e)
              Right transitMsg ->
                receiveFile conn transitserver appid transitMsg
    )
  liftEither result

-- | A file transfer application that takes an 'Env' and depending on the
-- config options, either sends or receives a file, directory or a text
-- message from the peer.
app :: App ()
app = do
  env <- ask
  let options = config env
      endpoint = relayEndpoint options
  case cmd options of
    Send tfd ->
      liftIO (MagicWormhole.runClient endpoint (appID env) (side env) $ \session ->
          runApp (sendSession tfd session) env) >>= liftEither
    Receive maybeCode ->
      liftIO (MagicWormhole.runClient endpoint (appID env) (side env) $ \session ->
          runApp (receiveSession maybeCode session) env) >>= liftEither
  where
    getWormholeCode :: MagicWormhole.Session -> [(Text, Text)] -> Maybe Text -> IO Text
    getWormholeCode session wordlist Nothing = getCode session wordlist
    getWormholeCode _ _ (Just code) = return code
    sendSession offerMsg session = do
      env <- ask
      password <- liftIO $ allocatePassword (wordList env)
      send session (toS password) offerMsg
    receiveSession code session = do
      env <- ask
      maybeCode <- liftIO $ getWormholeCode session (wordList env) code
      receive session maybeCode