allow connecting to TLS1.2 servers without EMS

[diohsc.git] / LineClient.hs

-- This file is part of Diohsc
-- Copyright (C) 2020-23 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

{-# LANGUAGE CPP               #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections     #-}

module LineClient (lineClient) where

import qualified Codec.MIME.Parse             as MIME
import qualified Codec.MIME.Type              as MIME
import           Control.Applicative          (Alternative, empty)
import           Control.Monad                (forM_, guard, join, mplus, msum,
                                               mzero, unless, void, when, (<=<))
import           Control.Monad.Catch          (SomeException, bracket,
                                               displayException, handle)
import           Control.Monad.IO.Class       (MonadIO, liftIO)
import           Control.Monad.State          (get, gets, lift, modify)
import           Control.Monad.Trans.Maybe    (MaybeT (..), runMaybeT)

import           Data.Bifunctor               (second)
import qualified Data.ByteString.Lazy         as BL
import           Data.Char                    (toLower)
import           Data.Hashable                (hash)
import           Data.IORef                   (modifyIORef, newIORef, readIORef)
import           Data.List                    (intercalate, isPrefixOf,
                                               isSuffixOf, sort, stripPrefix)
import qualified Data.Map                     as M
import           Data.Maybe
import qualified Data.Set                     as S
import qualified Data.Text                    as TS
import qualified Data.Text.Encoding.Error     as T
import qualified Data.Text.Lazy               as T
import qualified Data.Text.Lazy.Encoding      as T
import qualified Data.Text.Lazy.IO            as T

import           Safe
import qualified System.Console.Haskeline     as HL
import qualified System.Console.Terminal.Size as Size
import           System.Directory
import           System.Environment
import           System.FilePath
import           System.IO.Unsafe             (unsafeInterleaveIO)

import           Text.Regex                   (matchRegex, mkRegexWithOpts)
import           Time.System                  (timeCurrentP)

import           ActiveIdentities
import           Alias
import           ANSIColour
import qualified BStack
import           ClientCert                   (KeyType (..))
import           ClientOptions
import           ClientState
import           Command
import           CommandLine
import           GeminiProtocol
import           History
import           Identity
import           Marks
import           MetaString
import           Mundanities
import           Pager
import           PrintFancy
import           Prompt                       hiding (promptYN)
import qualified Prompt
import           Queue
import           Request
import           ResolveTarget
import qualified RunExternal
import           RunExternal                  hiding (runRestrictedIO)
import           Slurp
import           Target
import           TextGemini
import           URI
import           Util

#ifdef ICONV
import           Codec.Text.IConv             (convert)
#endif

#ifdef MAGIC
import qualified Magic
#endif

getTermSize :: IO (Int,Int)
getTermSize = do
    Size.Window height width <- fromMaybe (Size.Window (2^(30::Int)) 80) <$> Size.size
    return (height,width)

lineClient :: ClientOptions -> [String] -> Bool -> HL.InputT ClientM ()
lineClient cOpts@ClientOptions{ cOptUserDataDir = userDataDir
        , cOptInteractive = interactive, cOptAnsi = ansi, cOptGhost = ghost} initialCommands repl = do
    (liftIO . readFileLines $ userDataDir </> "diohscrc") >>= mapM_ (handleLine' . T.unpack)
    lift addToQueuesFromFiles
    mapM_ handleLine' initialCommands
    when repl lineClient'
    unless ghost $ lift appendQueuesToFiles
    where
    handleLine' :: String -> HL.InputT ClientM Bool
    handleLine' line = lift get >>= \s -> handleLine cOpts s line

    lineClient' :: HL.InputT ClientM ()
    lineClient' = do
        cmd <- lift getPrompt >>= promptLineInputT
        quit <- case cmd of
            Nothing -> if interactive
                then printErrFancy ansi "Use \"quit\" to quit" >> return False
                else return True
            Just Nothing -> return True
            Just (Just line) -> handleLine' line
        lift addToQueuesFromFiles
        unless quit lineClient'

    addToQueuesFromFiles :: ClientM ()
    addToQueuesFromFiles | ghost = return ()
        | otherwise = do
            qfs <- ignoreIOErr $ liftIO findQueueFiles
            forM_ qfs $ \(qfile, qname) ->
                modifyQueues . enqueue (QueueSpec qname Nothing) <=<
                    ignoreIOErr . liftIO $
                    mapMaybe queueLine <$> readFileLines qfile <* removeFile qfile
            ignoreIOErr . liftIO $ removeDirectory queuesDir
        where
        findQueueFiles :: IO [(FilePath,String)]
        findQueueFiles = do
            qf <- (\e -> [(queueFile, "") | e]) <$> doesFileExist queueFile
            qfs <- ((\qn -> (queuesDir </> qn, qn)) <$>) <$> listDirectory queuesDir
            return $ qf <> qfs
        queueLine :: T.Text -> Maybe QueueItem
        queueLine s = QueueURI Nothing <$> (parseUriAsAbsolute . escapeIRI $ T.unpack s)

    appendQueuesToFiles :: ClientM ()
    appendQueuesToFiles = do
        queues <- gets $ M.toList . clientQueues
        liftIO $ createDirectoryIfMissing True queuesDir
        liftIO $ forM_ queues appendQueue
        where
        appendQueue (_, []) = pure ()
        appendQueue (qname, queue) =
            let qfile = case qname of
                    "" -> queueFile
                    s  -> queuesDir </> s
            in warnIOErr $ BL.appendFile qfile .
                T.encodeUtf8 . T.unlines $ T.pack . show . queueUri <$> queue

    queueFile, queuesDir :: FilePath
    queueFile = userDataDir </> "queue"
    queuesDir = userDataDir </> "queues"

    getPrompt :: ClientM String
    getPrompt = do
        queue <- gets $ M.findWithDefault [] "" . clientQueues
        curr <- gets clientCurrent
        proxies <- gets $ clientConfProxies . clientConfig
        ais <- gets clientActiveIdentities
        let queueStatus :: Maybe String
            queueStatus = guard (not $ null queue) >> return (show (length queue) ++ "~")
            colour = applyIf ansi . withColourStr
            bold = applyIf ansi withBoldStr
            uriStatus :: Int -> URI -> String
            uriStatus w uri =
                let fullUriStr = stripGem $ show uri
                    stripGem s = fromMaybe s $ stripPrefix "gemini://" s
                    mIdName = (identityName <$>) $ findIdentity ais =<< requestOfProxiesAndUri proxies uri
                    idStr = flip (maybe "") mIdName $ \idName ->
                        let abbrId = length idName > 8 && length fullUriStr + 2 + length idName > w - 2
                        in "[" ++ (if abbrId then ".." ++ take 6 idName else idName) ++ "]"
                    abbrUri = length fullUriStr + length idStr > w - 2
                    uriFormat = colour BoldMagenta
                    uriStr = if abbrUri
                        then
                            let abbrUriChars = w - 4 - length idStr
                                preChars = abbrUriChars `div` 2
                                postChars = abbrUriChars - preChars
                            in uriFormat (take preChars fullUriStr) <>
                            ".." <>
                            uriFormat (drop (length fullUriStr - postChars) fullUriStr)
                        else uriFormat fullUriStr
                in uriStr ++
                    (if null idStr then "" else colour Green idStr)
            prompt :: Int -> String
            prompt maxPromptWidth =
                ((applyIf ansi withReverseStr $ colour BoldCyan "%%%") ++)
                    . (" " ++) . (++ bold "> ") . unwords $ catMaybes
                    [ queueStatus
                    , uriStatus (maxPromptWidth - 5 - maybe 0 ((+1) . length) queueStatus)
                        . historyUri <$> curr
                    ]
        prompt . min 40 . (`div` 2) . snd <$> liftIO getTermSize

handleLine :: ClientOptions -> ClientState -> String -> HL.InputT ClientM Bool
handleLine cOpts@ClientOptions{ cOptAnsi = ansi } s line = handle backupHandler . catchInterrupts $ case parseCommandLine line of
    Left err -> printErrFancy ansi err >> return False
    Right (CommandLine Nothing (Just (c,_))) | c `isPrefixOf` "quit" -> return True
    Right cline -> handleCommandLine cOpts s False cline >> return False
    where
    catchInterrupts = HL.handleInterrupt (printErrFancy ansi "Interrupted." >> return False) . HL.withInterrupt . lift
    backupHandler :: SomeException -> HL.InputT ClientM Bool
    backupHandler = (>> return False) . printErrFancy ansi . ("Unhandled exception: " <>) . show

handleCommandLine :: ClientOptions -> ClientState -> Bool -> CommandLine -> ClientM ()
handleCommandLine
        cOpts@(ClientOptions userDataDir interactive ansi ghost restrictedMode requestContext logH)
        cState@(ClientState curr jumpBack cLog visited queues _ marks sessionMarks aliases
            (ClientConfig defaultAction proxies geminators renderFilter preOpt linkDescFirst maxLogLen maxWrapWidth confNoConfirm verboseConnection))
        blockGo
    = \(CommandLine mt mcas) -> case mcas of
        Just (c,args) | Just (Alias _ (CommandLine mt' mcas')) <- lookupAlias c aliases ->
            let mcas'' = (, drop 1 args) . commandArgArg <$> headMay args
                appendCArgs (c',as') = (c', (appendTail <$> as') ++ args)
                    where
                    appendTail arg@(CommandArg a' t') = case args of
                        []                   -> arg
                        (CommandArg _ t : _) -> CommandArg a' $ t' <> " " <> t
            in handleCommandLine' (mt' `mplus` mt) $
                (appendCArgs <$> mcas') `mplus` mcas''
        _ -> handleCommandLine' mt mcas

    where

    -- Remark: we handle haskell's "configurations problem" by having the below all within the scope
    -- of the ClientOptions parameter. This is nicer to my mind than the heavier approaches of
    -- simulating global variables or threading a Reader monad throughout. The downside is that this
    -- module can't be split as much as it ought to be.
    -- Similar remarks go for `GeminiProtocol.makeRequest`.

    onRestriction :: IO ()
    onRestriction = printErr "This is not allowed in restricted mode."

    doRestricted :: Monoid a => RestrictedIO a -> IO a
    doRestricted m | restrictedMode = onRestriction >> return mempty
        | otherwise = RunExternal.runRestrictedIO m

    doRestrictedAlt :: Alternative f => RestrictedIO (f a) -> IO (f a)
    doRestrictedAlt m | restrictedMode = onRestriction >> return empty
        | otherwise = RunExternal.runRestrictedIO m

    doRestrictedFilter :: (a -> RestrictedIO a) -> (a -> IO a)
    doRestrictedFilter f | restrictedMode = \a -> do
            onRestriction
            return a
        | otherwise = RunExternal.runRestrictedIO . f

    printErr, printInfo :: MonadIO m => String -> m ()
    printErr = printErrFancy ansi
    printInfo = printInfoFancy ansi

    printIOErr :: IOError -> IO ()
    printIOErr = printErr . show

    noConfirm :: Bool
    noConfirm = confNoConfirm || not interactive

    confirm :: Applicative m => m Bool -> m Bool
    confirm | noConfirm = const $ pure True
        | otherwise = id

    promptYN = Prompt.promptYN interactive

    colour :: MetaString a => Colour -> a -> a
    colour = applyIf ansi . withColourStr
    bold :: MetaString a => a -> a
    bold = applyIf ansi withBoldStr

    isVisited :: URI -> Bool
    isVisited uri = S.member (hash . T.pack $ show uri) visited

    requestOfUri = requestOfProxiesAndUri proxies

    idAtUri :: ActiveIdentities -> URI -> Maybe Identity
    idAtUri ais uri = findIdentity ais =<< requestOfUri uri

    showUriRefFull :: MetaString a => Bool -> ActiveIdentities -> URI -> URIRef -> a
    showUriRefFull ansi' ais base ref = showUriFull ansi' ais (Just base) $ relativeTo ref base

    showUriFull :: MetaString a => Bool -> ActiveIdentities -> Maybe URI -> URI -> a
    showUriFull ansi' ais base uri =
        let scheme = uriScheme uri
            handled = scheme `elem` ["gemini","file"] || M.member scheme proxies
            inHistory = isJust $ curr >>= flip pathItemByUri uri
            activeId = isJust $ idAtUri ais uri
            col = if inHistory && not activeId then BoldBlue else case (isVisited uri,handled) of
                (True,True)   -> Yellow
                (False,True)  -> BoldYellow
                (True,False)  -> Red
                (False,False) -> BoldRed
            s = case base of
                Nothing -> show uri
                Just b  -> show $ relativeFrom uri b
        in fromString (applyIf ansi' (withColourStr col) s) <> case idAtUri ais uri of
            Nothing    -> ""
            Just ident -> showIdentity ansi' ident

    displayUri :: MetaString a => URI -> a
    displayUri = colour Yellow . fromString . show

    showUri :: URI -> ClientM ()
    showUri uri = do
        ais <- gets clientActiveIdentities
        liftIO . putStrLn $ showUriFull ansi ais Nothing uri

    addToLog :: URI -> ClientM ()
    addToLog uri = do
        let t = T.pack $ show uri
        modify $ \s -> s
            { clientLog = BStack.push maxLogLen t $ clientLog s
            , clientVisited = S.insert (hash . T.pack $ show uri) $ clientVisited s }
        unless ghost . liftIO $ maybe (return ()) (ignoreIOErr . (`T.hPutStrLn` t)) logH

    preprocessQuery :: String -> ClientM String
    preprocessQuery = (escapeQuery <$>) . liftIO . maybeEdit
        where
            maybeEdit :: String -> IO String
            maybeEdit s | lastMay s == Just '\\' =
                handle (\e -> printIOErr e >> pure s)
                    . doRestrictedFilter (editInteractively ansi userDataDir)
                    $ init s
            maybeEdit s = pure s

    expand :: String -> String
    expand = expandHelp ansi (fst <$> aliases) userDataDir

    idsPath = userDataDir </> "identities"
    savesDir = userDataDir </> "saves"
    marksDir = userDataDir </> "marks"

    historyEnv :: HistoryItem -> ClientM [(String,String)]
    historyEnv item = gets clientActiveIdentities >>= \ais -> pure $
        [ ("URI", show $ historyUri item)
        , ("MIMETYPE", showMimeType $ historyMimedData item) ] <>
        (maybe [] (identityEnvironment idsPath) . idAtUri ais $ historyUri item)

    setMark :: String -> URIWithIdName -> ClientM ()
    setMark mark uriId | markNameValid mark = do
        modify $ \s -> s { clientMarks = insertMark mark uriId $ clientMarks s }
        unless (mark `elem` tempMarks) . liftIO .
            handle printIOErr $ saveMark marksDir mark uriId
    setMark mark _ = printErr $ "Invalid mark name " ++ mark

    promptInput = if ghost then promptLine else promptLineWithHistoryFile inputHistPath
        where inputHistPath = userDataDir </> "inputHistory"

    handleCommandLine' :: Maybe PTarget -> Maybe (String, [CommandArg]) -> ClientM ()
    handleCommandLine' mt mcas = void . runMaybeT $ do
        ts <- case mt of
            Nothing -> return []
            Just pt -> either ((>> mzero) . printErr)
                (\ts -> mapM_ addTargetId ts >> return ts) $
                resolveTarget cState pt
        case mcas of
            Nothing -> lift $ handleBareTargets ts
            Just (s,as) -> do
                c' <- maybe (printErr (unknownCommand s) >> mzero)
                    return $ normaliseCommand s
                lift $ handleCommand ts (c',as)
        where
        unknownCommand s = "Unknown command \"" <> s <> "\". Type \"help\" for help."
        addTargetId :: Target -> MaybeT ClientM ()
        addTargetId (TargetIdUri idName uri) =
            liftIO (loadIdentity idsPath idName) >>= (\case
                (Nothing, _) -> printErr ("Bad URI: " ++ show uri) >> mzero
                (_, Nothing) -> printErr ("Unknown identity: " ++ showIdentityName ansi idName) >> mzero
                (Just req, Just ident) -> lift $ addIdentity req ident) . (requestOfUri uri,)
        addTargetId _ = return ()

    doPage :: [T.Text] -> ClientM ()
    doPage ls
        | interactive = do
            (height,width) <- liftIO getTermSize
            let pageWidth = min maxWrapWidth (width - 4)
                perPage = height - min 3 (height `div` 4)
                doCmd str = get >>= \s -> doSubCommand s True str
            printLinesPaged pageWidth width perPage doCmd ls
        | otherwise = liftIO $ mapM_ T.putStrLn ls

    handleBareTargets :: [Target] -> ClientM ()
    handleBareTargets [] = return ()
    handleBareTargets (_:_:_) =
        printErr "Can only go to one place at a time. Try \"show\" or \"page\"?"
    handleBareTargets [TargetHistory item] = goHistory item
    handleBareTargets [TargetFrom origin uri] = goUri False (Just origin) uri
    handleBareTargets [t] = goUri False Nothing $ targetUri t


    handleCommand :: [Target] -> (String, [CommandArg]) -> ClientM ()
    handleCommand _ (c,_) | restrictedMode && notElem c (commands True) =
        printErr "Command disabled in restricted mode"
    handleCommand [] ("help", args) = case args of
        []                 -> doPage . map (T.pack . expand) $ helpText
        CommandArg s _ : _ -> doPage . map (T.pack . expand) $ helpOn s
    handleCommand [] ("commands",_) = doPage $ T.pack . expand <$> commandHelpText
        where
        commandHelpText = ["Aliases:"] ++ (showAlias <$> aliases) ++
            ["","Commands:"] ++ (('{' :) . (<> "}") <$> commands False)
        showAlias (a, Alias s _) = "{" <> a <> "}: " <> s

    handleCommand [] ("mark", []) =
        let ms = M.toAscList marks
            markLine (m, Just uriId) = let m' = showMinPrefix ansi (fst <$> ms) m
                in T.pack $ "'" <> m' <>
                    replicate (max 1 $ 16 - visibleLength (T.pack m')) ' ' <>
                    showUriWithId uriId
            markLine (m, Nothing) = T.pack $ "'" <> m <> " [Failed to read mark]"
        in doPage $ markLine <$> ms
    handleCommand [] ("inventory",_) = do
        ais <- gets clientActiveIdentities
        let showNumberedUri :: Bool -> T.Text -> (Int,URI) -> T.Text
            showNumberedUri iter s (n,uri) = s <>
                (if iter && n == 1 then " "
                    else if iter && n == 2 then T.takeEnd 1 s
                    else T.pack (show n)) <>
                " " <> showUriFull ansi ais Nothing uri
            showIteratedItem s (n,item) = showNumberedUri True s (n, historyUri item)
            showNumberedItem s (n,item) = showNumberedUri False s (n, historyUri item)
            showIteratedQueueItem s (n, QueueURI _ uri) =
                showNumberedUri True s (n, uri)
            showIteratedQueueItem s (n, QueueHistory item) =
                showNumberedUri True s (n, historyUri item) <> " {fetched}"
            showJumpBack :: [T.Text]
            showJumpBack = maybeToList $ ("'' " <>) . showUriFull ansi ais Nothing . historyUri <$> jumpBack
        doPage . intercalate [""] . filter (not . null) $
            showJumpBack :
            [ showIteratedQueueItem (T.pack $ qname <> "~") <$> zip [1..] queue
                | (qname, queue) <- M.toList queues ]
            ++ [ showNumberedItem "'" <$> M.toAscList sessionMarks
            , (showIteratedItem "<" <$> zip [1..] (maybe [] (initSafe . historyAncestors) curr))
            ++ (("@  " <>) . showUriFull ansi ais Nothing . historyUri <$>
                maybeToList (curr >>= lastMay . historyAncestors))
            , showIteratedItem ">" <$> zip [1..] (maybe [] historyDescendants curr)
            ]
    handleCommand [] ("log",_) =
        let showLog (n,t) = "$" <> T.pack (show n) <> " " <> colour Yellow t
        in doPage $ showLog <$> zip [(1::Int)..] (BStack.toList cLog)
    handleCommand [] ("alias", CommandArg a _ : CommandArg _ str : _) = void . runMaybeT $ do
        c <- either ((>>mzero) . printErr) return $ parseCommand a
        when (c /= a) $ printErr ("Bad alias: " <> a) >> mzero
        cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
        modify $ \s ->
                s { clientAliases = insertAlias a (Alias str cl) . deleteAlias a $ clientAliases s }
    handleCommand [] ("alias", [CommandArg a _]) =
        modify $ \s -> s { clientAliases = deleteAlias a $ clientAliases s }
    handleCommand [] ("set", []) = liftIO $ do
        let (c,args) = defaultAction
        putStrLn $ expand "{default_action}: " <> c <>
            maybe "" ((" "<>) . commandArgLiteralTail) (headMay args)
        putStrLn $ expand "{proxies}:"
        printMap showHost $ M.toAscList proxies
        putStrLn $ expand "{geminators}:"
        printMap id $ second snd <$> geminators
        putStrLn $ expand "{render_filter}: " <> fromMaybe "" renderFilter
        putStrLn $ expand "{pre_display}: " <> showPreOpt preOpt
        putStrLn $ expand "{link_desc_first}: " <> show linkDescFirst
        putStrLn $ expand "{log_length}: " <> show maxLogLen
        putStrLn $ expand "{max_wrap_width}: " <> show maxWrapWidth
        putStrLn $ expand "{no_confirm}: " <> show noConfirm
        putStrLn $ expand "{verbose_connection}: " <> show verboseConnection
        where
            printMap :: (a -> String) -> [(String,a)] -> IO ()
            printMap f as = mapM_ putStrLn $
                (\(k,e) -> "  " <> k <> " " <> f e) <$> as
    handleCommand [] ("set", CommandArg opt _ : val)
        | opt `isPrefixOf` "default_action" = case val of
            (CommandArg cmd _ : args) -> case actionOfCommand (cmd,args) of
                Just _ -> modifyCConf $ \c -> c { clientConfDefaultAction = (cmd,args) }
                Nothing -> printErr "Invalid action"
            _ -> printErr "Require value for option."
        | opt `isPrefixOf` "proxies" || opt `isPrefixOf` "proxy" = case val of
            (CommandArg scheme _ : val') ->
                let f = maybe (M.delete scheme) (M.insert scheme) $
                        parseHost . commandArgLiteralTail =<< headMay val'
                in modifyCConf $ \c -> c { clientConfProxies = f $ clientConfProxies c }
                    -- if only I'd allowed myself to use lenses, eh?
            [] -> printErr "Require mimetype to set geminator for."
        | opt `isPrefixOf` "geminators" = case val of
            (CommandArg patt _ : val') ->
                let f = maybe (filter $ (/= patt) . fst)
                        (\v -> (++ [(patt, (mkRegexWithOpts patt True True,
                            commandArgLiteralTail v))])) $
                        headMay val'
                in modifyCConf $ \c -> c { clientConfGeminators = f $ clientConfGeminators c }
            [] -> printErr "Require mimetype to set geminator for."
        | opt `isPrefixOf` "render_filter" =
            modifyCConf $ \c -> c { clientConfRenderFilter =
                commandArgLiteralTail <$> headMay val }
        | opt `isPrefixOf` "pre_display" = case val of
            [CommandArg s _] | map toLower s `isPrefixOf` "both" ->
                modifyCConf $ \c -> c { clientConfPreOpt = PreOptBoth }
            [CommandArg s _] | map toLower s `isPrefixOf` "pre" ->
                modifyCConf $ \c -> c { clientConfPreOpt = PreOptPre }
            [CommandArg s _] | map toLower s `isPrefixOf` "alt" ->
                modifyCConf $ \c -> c { clientConfPreOpt = PreOptAlt }
            _ -> printErr "Require \"both\" or \"pre\" or \"alt\" for pre_display"
        | opt `isPrefixOf` "link_desc_first" = case val of
            [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
                modifyCConf $ \c -> c { clientConfLinkDescFirst = True }
            [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
                modifyCConf $ \c -> c { clientConfLinkDescFirst = False }
            _ -> printErr "Require \"true\" or \"false\" as value for link_desc_first"
        | opt `isPrefixOf` "log_length" = case val of
            [CommandArg s _] | Just n <- readMay s, n >= 0 -> do
                modifyCConf $ \c -> c { clientConfMaxLogLen = n }
                modify $ \st -> st { clientLog = BStack.truncate n $ clientLog st }
            _ -> printErr "Require non-negative integer value for log_length"
        | opt `isPrefixOf` "max_wrap_width" = case val of
            [CommandArg s _] | Just n <- readMay s, n > 0 ->
                modifyCConf $ \c -> c { clientConfMaxWrapWidth = n }
            _ -> printErr "Require positive integer value for max_wrap_width"
        | opt `isPrefixOf` "no_confirm" = case val of
            [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
                modifyCConf $ \c -> c { clientConfNoConfirm = True }
            [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
                modifyCConf $ \c -> c { clientConfNoConfirm = False }
            _ -> printErr "Require \"true\" or \"false\" as value for no_confirm"
        | opt `isPrefixOf` "verbose_connection" = case val of
            [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
                modifyCConf $ \c -> c { clientConfVerboseConnection = True }
            [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
                modifyCConf $ \c -> c { clientConfVerboseConnection = False }
            _ -> printErr "Require \"true\" or \"false\" as value for verbose_connection"
        | otherwise = printErr $ "No such option \"" <> opt <> "\"."
    handleCommand [] cargs =
        case curr of
            Just item -> handleCommand [TargetHistory item] cargs
            Nothing -> printErr "No current location. Enter an URI, or type \"help\"."

    handleCommand ts ("add", args) = case parseQueueSpec $ commandArgArg <$> args of
        Nothing -> printErr "Bad arguments to 'add'."
        Just qs -> modifyQueues . enqueue qs $ targetQueueItem <$> ts

    handleCommand ts ("fetch", args) = case parseQueueSpec $ commandArgArg <$> args of
        Nothing -> printErr "Bad arguments to 'fetch."
        Just qs -> do
            -- XXX: we have to use an IORef to store the items, since
            -- CommandAction doesn't allow a return value.
            lRef <- liftIO $ newIORef []
            let add item = liftIO $ slurpItem item >> modifyIORef lRef (item:)
            forM_ ts $ \t -> case t of
                TargetHistory item -> add item
                _ -> modifyQueues (unqueue uri) >> doRequestUri uri add
                    where uri = targetUri t
            l <- liftIO $ reverse <$> readIORef lRef
            modifyQueues . enqueue qs $ QueueHistory <$> l

    handleCommand ts cargs =
        mapM_ handleTargetCommand ts
        where
        handleTargetCommand (TargetHistory item) | Just action <- actionOfCommand cargs =
            action item
        handleTargetCommand t | Just action <- actionOfCommand cargs =
            let uri = targetUri t
            in modifyQueues (unqueue uri) >> doRequestUri uri action
        handleTargetCommand (TargetHistory item) | ("repeat",_) <- cargs =
            goUri True (recreateOrigin <$> historyParent item) $ historyUri item
        handleTargetCommand (TargetHistory item) | ("repl",_) <- cargs =
            repl (recreateOrigin <$> historyParent item) $ historyUri item
        handleTargetCommand t | ("query", CommandArg _ str : _) <- cargs = do
            let origin = case t of
                    TargetHistory item -> Just $ HistoryOrigin item Nothing
                    TargetFrom o _     -> Just o
                    _                  -> Nothing
            str' <- preprocessQuery str
            goUri True origin . setQuery ('?':str') $ targetUri t
        handleTargetCommand t =
            handleUriCommand (targetUri t) cargs

        recreateOrigin :: HistoryItem -> HistoryOrigin
        recreateOrigin parent = HistoryOrigin parent $ childLink =<< historyChild parent

        handleUriCommand uri ("delete",[]) =
            modifyQueues $ unqueueFrom "" uri
        handleUriCommand uri ("delete",CommandArg qname _ : _) =
            modifyQueues $ unqueueFrom qname uri
        handleUriCommand uri ("repeat",_) = goUri True Nothing uri
        handleUriCommand uri ("uri",_) = showUri uri
        handleUriCommand uri ("mark", CommandArg mark _ : _)
            | Just _ <- readMay mark :: Maybe Int = error "Bad mark for uri"
            | otherwise = do
            ais <- gets clientActiveIdentities
            let mIdName = case findIdentity ais =<< requestOfUri uri of
                    Just ident | not $ isTemporary ident -> Just $ identityName ident
                    _ -> Nothing
            setMark mark $ URIWithIdName uri mIdName
        handleUriCommand uri ("identify", args) = case requestOfUri uri of
            Nothing -> printErr "Bad URI"
            Just req -> gets ((`findIdentityRoot` req) . clientActiveIdentities) >>= \case
                Just (root,(ident,_)) | null args -> endIdentityPrompted root ident
                _ -> void . runMaybeT $ do
                    ident <- MaybeT . liftIO $ case args of
                        CommandArg idName _ : args' ->
                            let tp = case args' of
                                    CommandArg ('e':'d':_) _ : _ -> KeyEd25519
                                    _                            -> KeyRSA
                            in getIdentity interactive ansi idsPath tp idName
                        [] -> if interactive
                            then getIdentityRequesting ansi idsPath
                            else getIdentity interactive ansi idsPath KeyRSA ""
                    lift $ addIdentity req ident
        handleUriCommand uri ("browse", args) = do
            ais <- gets clientActiveIdentities
            let envir = maybe [] (identityEnvironment idsPath) .
                    idAtUri ais . setSchemeDefault $ uri
            void . liftIO . runMaybeT $ do
                cmd <- case args of
                    [] -> maybe notSet
                        (\s -> if null s then notSet else return $ parseBrowser s) =<<
                            lift (lookupEnv "BROWSER")
                        where
                        notSet = printErr "Please set $BROWSER or give a command to run" >> mzero
                        -- |based on specification for $BROWSER in 'man 1 man'
                        parseBrowser :: String -> String
                        parseBrowser = subPercentOrAppend (show uri) . takeWhile (/=':')
                    (CommandArg _ c : _) -> return $ subPercentOrAppend (show uri) c
                lift $ confirm (confirmShell "Run" cmd) >>? doRestricted $ void (runShellCmd cmd envir)
        handleUriCommand uri ("repl",_) = repl Nothing uri
        handleUriCommand uri ("log",_) = addToLog uri >> modifyQueues (unqueue uri)

        handleUriCommand _ (c,_) = printErr $ "Bad arguments to command " <> c

        repl :: Maybe HistoryOrigin -> URI -> ClientM ()
        repl origin uri = repl' where
            repl' = liftIO (join <$> promptInput ">> ") >>= \case
                Nothing -> return ()
                Just query -> do
                    query' <- preprocessQuery query
                    goUri True origin . setQuery ('?':query') $ uri
                    repl'

    slurpItem :: HistoryItem -> IO ()
    slurpItem item = slurpNoisily (historyRequestTime item) . mimedBody $ historyMimedData item

    actionOnRendered :: Bool -> ([T.Text] -> ClientM ()) -> CommandAction
    actionOnRendered ansi' m item = do
        ais <- gets clientActiveIdentities
        liftIO (renderMimed ansi' (historyUri item) ais (historyGeminatedMimedData item)) >>=
            either printErr m

    actionOfCommand :: (String, [CommandArg]) -> Maybe CommandAction
    actionOfCommand (c,_) | restrictedMode && notElem c (commands True) = Nothing
    actionOfCommand ("show",_) = Just . actionOnRendered ansi $ liftIO . mapM_ T.putStrLn
    actionOfCommand ("page",_) = Just $ actionOnRendered ansi doPage
    actionOfCommand ("links",_) = Just $ \item -> do
        ais <- gets clientActiveIdentities
        let cl = childLink =<< historyChild item
            linkLine n (Link uri desc) =
                applyIf (cl == Just (n-1)) (bold "* " <>) $
                T.pack ('[' : show n ++ "] ")
                    <> showUriRefFull ansi ais (historyUri item) uri
                    <> if T.null desc then "" else " " <>
                        applyIf ansi (withColourStr Cyan) desc
        doPage . zipWith linkLine [1..] . historyLinks $ item

    actionOfCommand ("mark", CommandArg mark _ : _) |
        Just n <- readMay mark :: Maybe Int = Just $ \item -> do
            liftIO $ slurpItem item
            modify $ \s -> s { clientSessionMarks = M.insert n item $ clientSessionMarks s }
    actionOfCommand ("mime",_) = Just $ liftIO . putStrLn . showMimeType . historyMimedData
    actionOfCommand ("save", []) = actionOfCommand ("save", [CommandArg "" savesDir])
    actionOfCommand ("save", CommandArg _ path : _) = Just $ \item -> liftIO . doRestricted . RestrictedIO $ do
        createDirectoryIfMissing True savesDir
        homePath <- getHomeDirectory
        let path'
                | take 2 path == "~/" = homePath </> drop 2 path
                | take 1 path == "/" || take 2 path == "./" || take 3 path == "../" = path
                | otherwise = savesDir </> path
            body = mimedBody $ historyMimedData item
            uri = historyUri item
            name = fromMaybe (fromMaybe "" $ uriRegName uri) . lastMay .
                filter (not . null) $ pathSegments uri
        handle printIOErr . void . runMaybeT $ do
            lift $ mkdirhierto path'
            isDir <- lift $ doesDirectoryExist path'
            let fullpath = if isDir then path' </> name else path'
            lift (doesDirectoryExist fullpath) >>? do
                lift . printErr $ "Path " ++ show fullpath ++ " exists and is directory"
                mzero
            lift (doesFileExist fullpath) >>?
                guard =<< lift (promptYN False $ "Overwrite " ++ show fullpath ++ "?")
            lift $ do
                putStrLn $ "Saving to " ++ fullpath
                t0 <- timeCurrentP
                BL.writeFile fullpath =<< interleaveProgress t0 body

    actionOfCommand ("!", CommandArg _ cmd : _) = Just $ \item -> do
        env <- historyEnv item
        liftIO . handle printIOErr . doRestricted .
            shellOnData noConfirm cmd userDataDir env . mimedBody $ historyMimedData item

    actionOfCommand ("view",_) = Just $ \item ->
        let mimed = historyMimedData item
            mimetype = showMimeType mimed
            body = mimedBody mimed
        in liftIO . handle printIOErr . doRestricted $ runMailcap noConfirm "view" userDataDir mimetype body
    actionOfCommand ("|", CommandArg _ cmd : _) = Just $ \item -> do
        env <- historyEnv item
        liftIO . handle printIOErr . doRestricted $
            pipeToShellLazily cmd env . mimedBody $ historyMimedData item
    actionOfCommand ("||", args) = Just $ pipeRendered ansi args
    actionOfCommand ("||-", args) = Just $ pipeRendered False args
    actionOfCommand ("cat",_) = Just $ liftIO . BL.putStr . mimedBody . historyMimedData
    actionOfCommand ("at", CommandArg _ str : _) = Just $ \item ->
        doSubCommand (cState { clientCurrent = Just item }) blockGo str
    actionOfCommand _ = Nothing

    pipeRendered :: Bool -> [CommandArg] -> CommandAction
    pipeRendered ansi' args item = (\action -> actionOnRendered ansi' action item) $ \ls -> do
        env <- historyEnv item
        liftIO . void . runMaybeT $ do
            cmd <- case args of
                [] -> maybe notSet
                    (\s -> if null s then notSet else return s) =<<
                    liftIO (lookupEnv "PAGER")
                    where
                    notSet = printErr "Please set $PAGER or give a command to run" >> mzero
                (CommandArg _ cmd : _) -> return cmd
            lift . doRestricted . pipeToShellLazily cmd env . T.encodeUtf8 $ T.unlines ls

    doSubCommand :: ClientState -> Bool -> String -> ClientM ()
    doSubCommand s block str = void . runMaybeT $ do
        cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
        lift $ handleCommandLine cOpts s block cl

    setCurr :: HistoryItem -> ClientM ()
    setCurr i =
        let isJump = isNothing $ curr >>= pathItemByUri i . historyUri
        in do
            when isJump $ modify $ \s -> s { clientJumpBack = curr }
            modify $ \s -> s { clientCurrent = Just i }

    doDefault :: HistoryItem -> ClientM ()
    doDefault item =
        maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction

    goHistory :: HistoryItem -> ClientM ()
    goHistory _ | blockGo = printErr "Can't go anywhere now."
    goHistory item = do
        modifyQueues $ unqueue uri
        showUri uri
        setCurr item
        doDefault item
        where uri = historyUri item

    goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM ()
    goUri _ _ _ | blockGo = printErr "Can't go anywhere now."
    goUri forceRequest origin uri = do
        modifyQueues $ unqueue uri
        activeId <- gets $ isJust . (`idAtUri` uri) . clientActiveIdentities
        case curr >>= flip pathItemByUri uri of
            Just i' | not (activeId || forceRequest) -> goHistory i'
            _ -> doRequestUri uri $ \item -> do
                let updateParent i =
                        -- Lazily recursively update the links in the doubly linked list
                        let i' = i { historyParent = updateParent . updateChild i' <$> historyParent i }
                        in i'
                    updateChild i' i = i { historyChild = setChild <$> historyChild i }
                        where setChild c = c { childItem = i' }
                    glueOrigin (HistoryOrigin o l) = updateParent $ o { historyChild = Just $ HistoryChild item' l }
                    item' = item { historyParent = glueOrigin <$> origin }
                setCurr item'
                doDefault item
                liftIO $ slurpItem item

    doRequestUri :: URI -> CommandAction -> ClientM ()
    doRequestUri uri0 action = doRequestUri' 0 uri0
        where
        doRequestUri' redirs uri
            | Just req <- requestOfUri uri = addToLog uri >> doRequest redirs req
            | otherwise = printErr $ "Bad URI: " ++ displayUri uri ++ (
                    let scheme = uriScheme uri
                    in if scheme /= "gemini" && isNothing (M.lookup scheme proxies)
                    then " : No proxy set for non-gemini scheme " ++ scheme ++ "; use \"browse\"?"
                    else "")

        doRequest :: Int -> Request -> ClientM ()
        doRequest redirs _ | redirs > 5 =
            printErr "Too many redirections!"
        doRequest redirs req@(NetworkRequest _ uri) = do
            (mId, ais) <- liftIO . useActiveIdentity noConfirm ansi req =<< gets clientActiveIdentities
            modify $ \s -> s { clientActiveIdentities = ais }
            printInfo $ ">>> " ++ showUriFull ansi ais Nothing uri
            let respBuffSize = 2 ^ (15::Int) -- 32KB max cache for response stream
            liftIO (makeRequest requestContext mId respBuffSize verboseConnection req)
                `bracket` either (\_ -> return ()) (liftIO . snd) $
                either
                    (printErr . displayException)
                    (handleResponse . fst)
            where
            handleResponse :: Response -> ClientM ()
            handleResponse (Input isPass prompt) = do
                let defaultPrompt = "[" ++ (if isPass then "PASSWORD" else "INPUT") ++ "]"
                (liftIO . (join <$>) . promptInput $
                        (if null prompt then defaultPrompt else prompt) ++ " > ") >>= \case
                    Nothing -> return ()
                    Just query -> do
                        query' <- preprocessQuery query
                        doRequestUri' redirs . setQuery ('?':query') $ uri

            handleResponse (Success mimedData) = doAction req mimedData

            handleResponse (Redirect isPerm to) = do
                ais <- gets clientActiveIdentities
                let uri' = to `relativeTo` uri
                    crossSite = uriRegName uri' /= uriRegName uri
                    crossScheme = uriScheme uri' /= uriScheme uri
                    crossScope = case idAtUri ais <$> [uri,uri'] of
                            [fromId,toId] -> isJust toId && fromId /= toId
                            _             -> False
                    warningStr = colour BoldRed
                proceed <- (isJust <$>) . lift . runMaybeT $ do
                    when crossSite $ guard <=< (liftIO . promptYN False) $
                        warningStr "Follow cross-site redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
                    when crossScheme $ guard <=< (liftIO . promptYN False) $
                        warningStr "Follow cross-protocol redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
                    when crossScope $ guard <=< (liftIO . promptYN False) $
                        warningStr "Follow redirect with identity " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
                when proceed $ do
                    when (isPerm && not ghost) . mapM_ (updateMark uri') . marksWithUri uri =<< gets clientMarks
                    doRequestUri' (redirs + 1) uri'
                where updateMark uri' (mark,uriId) = do
                        conf <- confirm . liftIO . promptYN True $ "Update mark '" <> mark <> " to " <> show uri' <> " ?"
                        when conf . setMark mark $ uriId { uriIdUri = uri' }
            handleResponse (Failure code info) | 60 <= code && code <= 69 = void . runMaybeT $ do
                identity <- do
                        liftIO . putStrLn $ (case code of
                            60 -> "Server requests identification"
                            _ -> "Server rejects provided identification certificate" ++
                                (if code == 61 then " as unauthorised" else if code == 62 then " as invalid" else ""))
                            ++ if null info then "" else ": " ++ info
                        guard interactive
                        MaybeT . liftIO $ getIdentityRequesting ansi idsPath
                lift $ do
                    addIdentity req identity
                    doRequest redirs req

            handleResponse (Failure code info) =
                printErr $ "Server returns failure: " ++ show code ++ " " ++ info
            handleResponse (MalformedResponse malformation) =
                printErr $ "Malformed response from server: " ++ show malformation

        doRequest redirs (LocalFileRequest path) | redirs > 0 = printErr "Ignoring redirect to local file."
            | otherwise = void . runMaybeT $ do
                (path', mimedData) <- MaybeT . liftIO . doRestrictedAlt . RestrictedIO . warnIOErrAlt $ do
                    let detectExtension = case takeExtension path of
                            -- |certain crucial filetypes we can't rely on magic to detect:
                            s | s `elem` [".gmi", ".gem", ".gemini"] -> Just "text/gemini"
                            ".md" -> Just "text/markdown"
                            ".html" -> Just "text/html"
                            _ -> Nothing
#ifdef MAGIC
                        detectPlain "text/plain" = fromMaybe "text/plain" detectExtension
                        detectPlain s = s
                    magic <- Magic.magicOpen [Magic.MagicMimeType]
                    Magic.magicLoadDefault magic
                    s <- detectPlain <$> Magic.magicFile magic path
#else
                    let s = if "/" `isSuffixOf` path then "inode/directory"
                            else fromMaybe "application/octet-stream" detectExtension
#endif
                    case MIME.parseMIMEType $ TS.pack s of
                        Nothing -> printErr ("Failed to parse mimetype string: " <> s) >> return Nothing
                        _ | s == "inode/directory" -> Just . (slashedPath,) . MimedData gemTextMimeType .
                            T.encodeUtf8 . T.unlines .
                            ((("=> " <>) . T.pack . escapePathString) <$>) . sort <$>
                                getDirectoryContents path
                            where slashedPath | "/" `isSuffixOf` path = path
                                    | otherwise = path <> "/"
                        Just mimetype -> Just . (path,) . MimedData mimetype <$> BL.readFile path
                lift $ doAction (LocalFileRequest path') mimedData

        doAction req mimedData = do
            t0 <- liftIO timeCurrentP
            geminated <- geminate mimedData
            action $ HistoryItem req t0 mimedData geminated Nothing Nothing
            where
            -- |returns MimedData with lazy IO
            geminate :: MimedData -> ClientM MimedData
            geminate mimed =
                let geminator = lookupGeminator $ showMimeType mimed
                in liftIO . unsafeInterleaveIO $ applyGeminator geminator
                where
                lookupGeminator mimetype =
                    listToMaybe [ gem | (_, (regex, gem)) <- geminators
                        , isJust $ matchRegex regex mimetype ]
                applyGeminator Nothing = return mimed
                applyGeminator (Just cmd) =
                    printInfo ("| " <> cmd) >>
                    MimedData gemTextMimeType <$>
                        doRestrictedFilter (filterShell cmd [("URI", show $ requestUri req)]) (mimedBody mimed)

        gemTextMimeType :: MIME.Type
        gemTextMimeType = MIME.Type (MIME.Text "gemini") []


    addIdentity :: Request -> Identity -> ClientM ()
    addIdentity req identity = do
        ais <- gets clientActiveIdentities >>= liftIO . insertIdentity req identity
        modify $ \s -> s {clientActiveIdentities = ais}
    endIdentityPrompted :: Request -> Identity -> ClientM ()
    endIdentityPrompted root ident = do
        conf <- confirm $ liftIO . promptYN False $ "Stop using " ++
            (if isTemporary ident then "temporary anonymous identity" else showIdentity ansi ident) ++
            " at " ++ displayUri (requestUri root) ++ "?"
        when conf . modify $ \s ->
                s { clientActiveIdentities = deleteIdentity root $ clientActiveIdentities s }

    renderMimed :: Bool -> URI -> ActiveIdentities -> MimedData -> IO (Either String [T.Text])
    renderMimed ansi' uri ais (MimedData mime body) = case MIME.mimeType mime of
        MIME.Text textType -> do
            let extractCharsetParam (MIME.MIMEParam "charset" v) = Just v
                extractCharsetParam _                            = Nothing
                charset = TS.unpack . fromMaybe "utf-8" . msum . map extractCharsetParam $ MIME.mimeParams mime
                isUtf8 = map toLower charset `elem` ["utf-8", "utf8"]
#ifdef ICONV
                reencoder = if isUtf8 then id else
                    convert charset "UTF-8"
#else
                reencoder = id
            unless isUtf8 . printErr $
                "Warning: Treating unsupported charset " ++ show charset ++ " as utf-8"
#endif
            (_,width) <- getTermSize
            let pageWidth = if interactive
                then min maxWrapWidth (width - 4)
                else maxWrapWidth
            let bodyText = T.decodeUtf8With T.lenientDecode $ reencoder body
                applyFilter :: [T.Text] -> IO [T.Text]
                applyFilter = case renderFilter of
                    Nothing -> return
                    Just cmd -> (T.lines . T.decodeUtf8With T.lenientDecode <$>) .
                        doRestrictedFilter (filterShell cmd []) . BL.concat . (appendNewline . T.encodeUtf8 <$>)
                        where appendNewline = (`BL.snoc` 10)
            (Right <$>) . applyFilter $ case textType of
                    "gemini" ->
                        let opts = GemRenderOpts ansi' preOpt pageWidth linkDescFirst
                        in printGemDoc opts (showUriRefFull ansi' ais uri) $ parseGemini bodyText
                    _ -> T.stripEnd . stripControl <$> T.lines bodyText
        mimeType ->
            return . Left $ "No geminator for " ++ TS.unpack (MIME.showMIMEType mimeType) ++ " configured. Try \"save\", \"view\", \"!\", or \"|\"?"