-- This file is part of Diohsc
-- Copyright (C) 2020 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 Main where

import           Control.Applicative          (Alternative, empty)
import           Control.Monad.Catch
import           Control.Monad.State
import           Control.Monad.Trans.Maybe    (MaybeT (..), runMaybeT)
import           Data.Bifunctor               (second)
import           Data.Char                    (isAlpha, isUpper, toLower)
import           Data.Hash                    (Hash, hash)
import           Data.IORef                   (modifyIORef, newIORef, readIORef)
import           Data.List                    (find, intercalate, isPrefixOf,
                                               isSuffixOf, sort, stripPrefix)
import           Data.Maybe
import           Safe
import           System.Directory
import           System.Environment
import           System.Exit
import           System.FilePath
import           System.IO
import           System.IO.Unsafe             (unsafeInterleaveIO)
import           Text.Regex                   (Regex, matchRegex,
                                               mkRegexWithOpts)
import           Time.System                  (timeCurrentP)
import           Time.Types                   (ElapsedP)

import qualified Data.ByteString.Lazy         as BL

import qualified Codec.MIME.Parse             as MIME
import qualified Codec.MIME.Type              as MIME
import qualified Data.Map                     as M
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 qualified System.Console.Haskeline     as HL
import qualified System.Console.Terminal.Size as Size

import           ANSIColour
import           ActiveIdentities
import           Alias
import qualified BStack
import           ClientCert                   (KeyType (..))
import           Command
import           CommandLine
import           GeminiProtocol
import           Identity
import           Marks
import           MetaString
import           Mundanities
import           Opts
import           Pager
import           Prompt                       hiding (promptYN)
import qualified Prompt
import           Request
import           RunExternal                  hiding (runRestrictedIO)
import qualified RunExternal
import           Slurp
import           TextGemini
import           URI
import           Util
import           Version

#ifndef WINDOWS
import           System.Posix.Files           (ownerModes, setFileMode)
#endif

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

#ifdef MAGIC
import qualified Magic
#endif

-- |Immutable options set at startup
data ClientOptions = ClientOptions
    { cOptUserDataDir    :: FilePath
    , cOptInteractive    :: Bool
    , cOptAnsi           :: Bool
    , cOptGhost          :: Bool
    , cOptRestrictedMode :: Bool
    , cOptRequestContext :: RequestContext
    , cOptLogH           :: Maybe Handle
    }

data HistoryChild = HistoryChild
    { childItem :: HistoryItem
    , childLink :: Maybe Int
    }

data HistoryOrigin = HistoryOrigin
    { originItem :: HistoryItem
    , originLink :: Maybe Int
    }

data HistoryItem = HistoryItem
    { historyRequest            :: Request
    , historyRequestTime        :: ElapsedP
    , historyMimedData          :: MimedData
    , historyGeminatedMimedData :: MimedData -- ^generated with lazy IO
    , historyParent             :: Maybe HistoryItem
    , historyChild              :: Maybe HistoryChild
    }

historyUri :: HistoryItem -> URI
historyUri = requestUri . historyRequest

historyEnv :: HistoryItem -> [(String,String)]
historyEnv item =
    [ ("URI", show $ historyUri item)
    , ("MIMETYPE", showMimeType $ historyMimedData item) ]

historyAncestors :: HistoryItem -> [HistoryItem]
historyAncestors i = case historyParent i of
        Nothing -> []
        Just i' -> i' : historyAncestors i'

historyDescendants :: HistoryItem -> [HistoryItem]
historyDescendants i = case historyChild i of
        Nothing                  -> []
        Just (HistoryChild i' _) -> i' : historyDescendants i'

pathItemByUri :: HistoryItem -> URI -> Maybe HistoryItem
pathItemByUri i uri = find ((uri ==) . historyUri) $
    historyAncestors i ++ [i] ++ historyDescendants i

data ClientConfig = ClientConfig
    { clientConfDefaultAction     :: (String, [CommandArg])
    , clientConfProxies           :: M.Map String Host
    , clientConfGeminators        :: [(String,(Regex,String))]
    , clientConfRenderFilter      :: Maybe String
    , clientConfPreOpt            :: PreOpt
    , clientConfLinkDescFirst     :: Bool
    , clientConfMaxLogLen         :: Int
    , clientConfMaxWrapWidth      :: Int
    , clientConfNoConfirm         :: Bool
    , clientConfVerboseConnection :: Bool
    }

defaultClientConfig :: ClientConfig
defaultClientConfig = ClientConfig ("page", []) M.empty [] Nothing PreOptPre False 1000 80 False False

data QueueItem
    = QueueURI (Maybe HistoryOrigin) URI
    | QueueHistory HistoryItem

queueUri :: QueueItem -> URI
queueUri (QueueURI _ uri)    = uri
queueUri (QueueHistory item) = historyUri item

data ClientState = ClientState
    { clientCurrent          :: Maybe HistoryItem
    , clientJumpBack         :: Maybe HistoryItem
    , clientLog              :: BStack.BStack T.Text
    , clientVisited          :: S.Set Hash
    , clientQueues           :: M.Map String [QueueItem]
    , clientActiveIdentities :: ActiveIdentities
    , clientMarks            :: Marks
    , clientSessionMarks     :: M.Map Int HistoryItem
    , clientAliases          :: Aliases
    , clientQueuedCommands   :: [String]
    , clientConfig           :: ClientConfig
    }

type ClientM = StateT ClientState IO

type CommandAction = HistoryItem -> ClientM ()

emptyClientState :: ClientState
emptyClientState = ClientState Nothing Nothing BStack.empty S.empty M.empty M.empty emptyMarks M.empty defaultAliases [] defaultClientConfig

enqueue :: String -> Maybe Int -> [QueueItem] -> ClientM ()
enqueue _ _ [] = return ()
enqueue qname after qs = modify $ \s -> s {clientQueues =
        M.alter (Just . insertInNubbedList after qs queueUri) qname $ clientQueues s}

insertInNubbedList :: Eq b => Maybe Int -> [a] -> (a -> b) -> Maybe [a] -> [a]
insertInNubbedList mn as f mbs =
    let bs = fromMaybe [] mbs
        (bs',bs'') = maybe (bs,[]) (`splitAt` bs) mn
        del as' = filter $ (`notElem` (f <$> as')) . f
    in del as bs' ++ as ++ del as bs''

dropUriFromQueue :: String -> URI -> ClientM ()
dropUriFromQueue qname uri = modify $ \s -> s { clientQueues =
        M.adjust (filter ((/= uri) . queueUri)) qname $ clientQueues s }

dropUriFromQueues :: URI -> ClientM ()
dropUriFromQueues uri = do
    qnames <- gets $ M.keys . clientQueues
    forM_ qnames (`dropUriFromQueue` uri)

popQueuedCommand :: ClientM (Maybe String)
popQueuedCommand = do
    cmd <- gets $ headMay . clientQueuedCommands
    when (isJust cmd) . modify $ \s ->
        s { clientQueuedCommands = drop 1 $ clientQueuedCommands s }
    return cmd

modifyCConf :: (ClientConfig -> ClientConfig) -> ClientM ()
modifyCConf f = modify $ \s -> s { clientConfig = f $ clientConfig s }

main :: IO ()
main = do
    argv <- getArgs
    (opts,args) <- parseArgs argv
    when (Help `elem` opts) $ putStr usage >> exitSuccess
    when (Version `elem` opts) $ putStrLn version >> exitSuccess

    defUserDataDir <- getAppUserDataDirectory programName
    userDataDir <- canonicalizePath . fromMaybe defUserDataDir $ listToMaybe [ path | DataDir path <- opts ]
    let restrictedMode = Restricted `elem` opts

    outTerm <- hIsTerminalDevice stdout
    let ansi = NoAnsi `notElem` opts && (outTerm || Ansi `elem` opts)

    let argCommands (ScriptFile "-") = warnIOErrAlt $
            (T.unpack . T.strip <$>) . T.lines <$> T.getContents
        argCommands (ScriptFile f) = warnIOErrAlt $ (T.unpack <$>) <$> readFileLines f
        argCommands (OptCommand c) = return [c]
        argCommands _ = return []
    optCommands <- concat <$> mapM argCommands opts
    let repl = (null optCommands && Batch `notElem` opts) || Prompt `elem` opts
    let interactive = Batch `notElem` opts && (repl || Interactive `elem` opts)

    let argToUri arg = doesPathExist arg >>= \case
            True -> Just . ("file://" <>) . escapePathString <$> makeAbsolute arg
            False | Just uri <- parseUriAsAbsolute . escapeIRI $ arg -> return $ Just $ show uri
            _ -> printErrOpt ansi ("No such URI / file: " <> arg) >> return Nothing
    argCommand <- join <$> mapM argToUri (listToMaybe args)

    let initialCommands = optCommands ++ maybeToList argCommand

    let ghost = Ghost `elem` opts

    unless ghost $ do
        mkdirhier userDataDir
#ifndef WINDOWS
        setFileMode userDataDir ownerModes -- chmod 700
#endif

    let cmdHistoryPath = userDataDir </> "commandHistory"
        marksPath = userDataDir </> "marks"
        logPath = userDataDir </> "log"

    let displayInfo :: [String] -> IO ()
        displayInfo = mapM_ $ printInfoOpt ansi
        displayWarning = mapM_ $ printErrOpt ansi
        promptYN = Prompt.promptYN interactive
        callbacks = InteractionCallbacks displayInfo displayWarning waitKey promptYN
        socksProxy = maybe (const NoSocksProxy) Socks5Proxy
            (listToMaybe [ h | SocksHost h <- opts ])
            . fromMaybe "1080" $ listToMaybe [ p | SocksPort p <- opts ]

    requestContext <- initRequestContext callbacks userDataDir ghost socksProxy
    (warnings, marks) <- loadMarks marksPath
    displayWarning warnings
    let hlSettings = (HL.defaultSettings::HL.Settings ClientM)
            { HL.complete = HL.noCompletion
            , HL.historyFile = if ghost then Nothing else Just cmdHistoryPath
            }

    cLog <- BStack.fromList . reverse <$> readFileLines logPath
    let visited = S.fromList $ hash . T.unpack <$> BStack.toList cLog

    let openLog :: IO (Maybe Handle)
        openLog = ignoreIOErrAlt $ Just <$> do
            h <- openFile logPath AppendMode
            hSetBuffering h LineBuffering
            return h
        closeLog :: Maybe Handle -> IO ()
        closeLog = maybe (return ()) hClose

    (if ghost then ($ Nothing) else bracketOnError openLog closeLog) $ \logH ->
        let clientOptions = ClientOptions userDataDir interactive ansi ghost
                restrictedMode requestContext logH
            initState = emptyClientState {clientMarks = marks
                , clientLog = cLog, clientVisited = visited}
        in do
            endState <- (`execStateT` initState) . HL.runInputT hlSettings $
                lineClient clientOptions initialCommands repl
            closeLog logH
            -- |reread file rather than just writing clientLog, in case another instance has also
            -- been appending to the log.
            unless ghost . warnIOErr $ truncateToEnd (clientConfMaxLogLen $ clientConfig endState) logPath

printErrOpt :: MonadIO m => Bool -> String -> m ()
printErrOpt ansi s = liftIO . hPutStrLn stderr . applyIf ansi (withColourStr BoldRed) $ "! " <> s

printInfoOpt :: MonadIO m => Bool -> String -> m ()
printInfoOpt ansi s = liftIO . hPutStrLn stderr $ applyIf ansi withBoldStr ". " <> s

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 <- runMaybeT $ msum
            [ do
                c <- MaybeT $ lift popQueuedCommand
                printInfoOpt ansi $ "> " <> c
                return $ Just c
            , MaybeT $ lift getPrompt >>= promptLineInputT ]
        lift addToQueuesFromFiles
        quit <- case cmd of
            Nothing -> if interactive
                then printErrOpt ansi "Use \"quit\" to quit" >> return False
                else return True
            Just Nothing -> return True
            Just (Just line) -> handleLine' line
        unless quit lineClient'

    addToQueuesFromFiles :: ClientM ()
    addToQueuesFromFiles | ghost = return ()
        | otherwise = do
            qfs <- ignoreIOErr $ liftIO findQueueFiles
            forM_ qfs $ \(qfile, qname) -> enqueue qname Nothing <=<
                ignoreIOErr . liftIO $
                catMaybes . (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 -> printErrOpt ansi err >> return False
    Right (CommandLine Nothing (Just (c,_))) | c `isPrefixOf` "quit" -> return True
    Right cline -> handleCommandLine cOpts s cline >> return False
    where
    catchInterrupts = HL.handleInterrupt (printErrOpt ansi "Interrupted." >> return False) . HL.withInterrupt . lift
    backupHandler :: SomeException -> HL.InputT ClientM Bool
    backupHandler = (>> return False) . printErrOpt ansi . ("Unhandled exception: " <>) . show

data Target
    = TargetHistory HistoryItem
    | TargetFrom HistoryOrigin URI
    | TargetIdUri String URI
    | TargetUri URI

targetUri :: Target -> URI
targetUri (TargetHistory item) = historyUri item
targetUri (TargetFrom _ uri)   = uri
targetUri (TargetIdUri _ uri)  = uri
targetUri (TargetUri uri)      = uri

targetQueueItem :: Target -> QueueItem
targetQueueItem (TargetFrom o uri)   = QueueURI (Just o) uri
targetQueueItem (TargetHistory item) = QueueHistory item
targetQueueItem i                    = QueueURI Nothing $ targetUri i

handleCommandLine :: ClientOptions -> ClientState -> 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))
    = \(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

    printInfo :: MonadIO m => String -> m ()
    printInfo = printInfoOpt ansi
    printErr :: MonadIO m => String -> m ()
    printErr = printErrOpt 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 $ 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 $ show uri) $ clientVisited s }
        unless ghost . liftIO $ maybe (return ()) (ignoreIOErr . (`T.hPutStrLn` t)) logH

    loggedUris = catMaybes $ (parseAbsoluteUri . escapeIRI . T.unpack <$>) $ BStack.toList cLog

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

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

    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 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 ()

    resolveTarget :: PTarget -> Either String [Target]
    resolveTarget PTargetCurr =
        (:[]) . TargetHistory <$> maybeToEither "No current location" curr

    resolveTarget PTargetJumpBack =
        (:[]) . TargetHistory <$> maybeToEither "'' mark not set" jumpBack

    resolveTarget (PTargetMark s)
        | Just n <- readMay s =
            (:[]) . TargetHistory <$> maybeToEither ("Mark not set: " <> s) (M.lookup n sessionMarks)
        | otherwise =
            (:[]) . targetOfMark <$> maybeToEither ("Unknown mark: " <> s) (lookupMark s marks)
            where
            targetOfMark (URIWithIdName uri Nothing) = TargetUri uri
            targetOfMark (URIWithIdName uri (Just idName)) = TargetIdUri idName uri

    resolveTarget (PTargetLog specs) =
        (TargetUri <$>) <$> resolveElemsSpecs "log entry" (matchPatternOn show) loggedUris specs

    resolveTarget (PTargetQueue qname specs) =
        (queueTarget <$>) <$> resolveElemsSpecs "queue item"
            (matchPatternOn $ show . queueUri) queue specs
        where
        queue = M.findWithDefault [] qname queues
        queueTarget (QueueURI Nothing uri)  = TargetUri uri
        queueTarget (QueueURI (Just o) uri) = TargetFrom o uri
        queueTarget (QueueHistory item)     = TargetHistory item

    resolveTarget (PTargetRoot base) =
        (rootOf <$>) <$> resolveTarget base
        where
        rootOf :: Target -> Target
        rootOf (TargetHistory item)                  = rootOfItem item
        rootOf (TargetFrom (HistoryOrigin item _) _) = rootOfItem item
        rootOf t                                     = t
        rootOfItem item = TargetHistory . lastDef item $ historyAncestors item

    resolveTarget (PTargetAncestors base specs) =
        concat <$> (mapM resolveAncestors =<< resolveTarget base)
        where
        resolveAncestors :: Target -> Either String [Target]
        resolveAncestors (TargetHistory item) =
            resolveAncestors' $ historyAncestors item
        resolveAncestors (TargetFrom (HistoryOrigin item _) _) =
            resolveAncestors' $ item : historyAncestors item
        resolveAncestors _ = Left "No history"
        resolveAncestors' hist = (TargetHistory <$>) <$>
            resolveElemsSpecs "ancestor" (matchPatternOn $ show . historyUri)
                hist specs

    resolveTarget (PTargetDescendants base specs) =
        concat <$> (mapM resolveDescendants =<< resolveTarget base)
        where
        resolveDescendants :: Target -> Either String [Target]
        resolveDescendants (TargetHistory item) = (TargetHistory <$>) <$>
            resolveElemsSpecs "descendant" (matchPatternOn $ show . historyUri)
                (historyDescendants item) specs
        resolveDescendants _ = Left "No history"

    resolveTarget (PTargetChild increasing noVisited base specs) =
        concat <$> (mapM resolveChild =<< resolveTarget base)
        where
        resolveChild (TargetHistory item) =
            let itemLinks = extractLinksMimed $ historyGeminatedMimedData item
                b = case historyChild item of
                    Just (HistoryChild _ (Just b')) -> b'
                    _ | increasing                  -> -1
                    _                               -> length itemLinks
                slice | increasing = zip [b+1..] $ drop (b+1) itemLinks
                    | otherwise = zip (reverse [0..b-1]) . reverse $ take b itemLinks
                linkUnvisited (_,l) = not . isVisited $ linkUri l `relativeTo` historyUri item
                slice' = applyIf noVisited (filter linkUnvisited) slice
            in resolveLinkSpecs False item slice' specs
        resolveChild _ = Left "No known links"

    resolveTarget (PTargetLinks noVisited base specs) =
        concat <$> (mapM resolveLinks =<< resolveTarget base)
        where
        resolveLinks (TargetHistory item) =
            let itemLinks = extractLinksMimed $ historyGeminatedMimedData item
            in resolveLinkSpecs noVisited item (zip [0..] itemLinks) specs
        resolveLinks _ = Left "No known links"

    resolveTarget (PTargetRef base s) =
        let makeRel r | base == PTargetCurr = r
            makeRel r@('/':_) = '.':r
            makeRel r = r
        in case parseUriReference . escapeIRI . escapeQueryPart $ makeRel s of
            Nothing -> Left $ "Failed to parse relative URI: " <> s
            Just ref -> map relTarget <$> resolveTarget base
                where
                relTarget (TargetHistory item) = TargetFrom (HistoryOrigin item Nothing) $
                    ref `relativeTo` historyUri item
                relTarget (TargetFrom o uri) = TargetFrom o $ relativeTo ref uri
                relTarget t = TargetUri . relativeTo ref $ targetUri t

    resolveTarget (PTargetAbs s) = case parseUriAsAbsolute . escapeIRI $ escapeQueryPart s of
        Nothing  -> Left $ "Failed to parse URI: " <> s
        Just uri -> return [TargetUri uri]

    resolveLinkSpecs :: Bool -> HistoryItem -> [(Int,Link)] -> ElemsSpecs -> Either String [Target]
    resolveLinkSpecs purgeVisited item slice specs =
        let isMatch s (_,l) = matchPattern s (show $ linkUri l) ||
                matchPattern s (T.unpack $ linkDescription l)
            linkTarg (n,l) =
                let uri = linkUri l `relativeTo` historyUri item
                in if purgeVisited && isVisited uri then Nothing
                    else Just $ TargetFrom (HistoryOrigin item $ Just n) uri
        in resolveElemsSpecs "link" isMatch slice specs >>= (\case
            []    -> Left "No such link"
            targs -> return targs) . catMaybes . (linkTarg <$>)

    matchPattern :: String -> String -> Bool
    matchPattern patt =
        let regex = mkRegexWithOpts patt True (any isUpper patt)
        in isJust . matchRegex regex

    matchPatternOn :: (a -> String) -> String -> a -> Bool
    matchPatternOn f patt = matchPattern patt . f

    doPage :: [T.Text] -> ClientM ()
    doPage ls
        | interactive = do
        (height,width) <- liftIO getTermSize
        let pageWidth = min maxWrapWidth (width - 4)
        let perPage = height - min 3 (height `div` 4)
        queued <- liftIO $ printLinesPaged pageWidth width perPage ls
        modify $ \s -> s { clientQueuedCommands = clientQueuedCommands s ++ queued }
        | otherwise = liftIO $ mapM_ T.putStrLn ls

    parseQueueSpec :: [CommandArg] -> Maybe (String, Maybe Int)
    parseQueueSpec [] = Just ("", Nothing)
    parseQueueSpec [CommandArg a _] | Just n <- readMay a = Just ("", Just n)
    parseQueueSpec (CommandArg a _:as) | not (null a), all isAlpha a
        , Just mn <- case as of
            []                                       -> Just Nothing
            [CommandArg a' _] | Just n <- readMay a' -> Just (Just n)
            _                                        -> Nothing
        = Just (a, mn)
    parseQueueSpec _ = Nothing

    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, uriId) = let m' = showMinPrefix ansi (fst <$> ms) m
                in T.pack $ "'" <> m' <>
                    replicate (max 1 $ 16 - visibleLength (T.pack m')) ' ' <>
                    showUriWithId uriId
        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 args of
        Nothing          -> printErr "Bad arguments to 'add'."
        Just (qname, mn) -> enqueue qname mn $ targetQueueItem <$> ts

    handleCommand ts ("fetch", args) = case parseQueueSpec args of
        Nothing -> printErr "Bad arguments to 'fetch."
        Just (qname, mn) -> 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
                _ -> dropUriFromQueues uri >> doRequestUri uri add
                    where uri = targetUri t
            l <- liftIO $ reverse <$> readIORef lRef
            enqueue qname mn $ 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 dropUriFromQueues 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 (TargetHistory item) =
            handleUriCommand (historyUri item) cargs
        handleTargetCommand t =
            handleUriCommand (targetUri t) cargs

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

        handleUriCommand uri ("delete",[]) = dropUriFromQueue "" uri
        handleUriCommand uri ("delete",CommandArg qname _ : _) = dropUriFromQueue 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) = 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 [])
        handleUriCommand uri ("repl",_) = repl Nothing uri
        handleUriCommand uri ("query", CommandArg _ str : _) =
                    goUri True Nothing . setQuery ('?':escapeQuery str) $ uri
        handleUriCommand uri ("log",_) = addToLog uri >> dropUriFromQueues 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
                    goUri True origin . setQuery ('?':escapeQuery 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..] . extractLinksMimed . historyGeminatedMimedData $ 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 -> liftIO . handle printIOErr . doRestricted .
        shellOnData noConfirm cmd userDataDir (historyEnv item) . 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 -> liftIO . handle printIOErr . doRestricted $
        pipeToShellLazily cmd (historyEnv item) . 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 -> void . runMaybeT $ do
        cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
        lift $ handleCommandLine cOpts (cState { clientCurrent = Just item }) cl
    actionOfCommand _ = Nothing

    pipeRendered :: Bool -> [CommandArg] -> CommandAction
    pipeRendered ansi' args item = (\action -> actionOnRendered ansi' action item) $ \ls ->
        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 (historyEnv item) . T.encodeUtf8 $ T.unlines ls

    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 item = do
        dropUriFromQueues uri
        showUri uri
        doDefault item
        setCurr item
        where uri = historyUri item

    goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM ()
    goUri forceRequest origin uri = do
        dropUriFromQueues uri
        activeId <- gets $ isJust . (`idAtUri` uri) . clientActiveIdentities
        case curr >>= flip pathItemByUri uri of
            Just i' | not (activeId || forceRequest) -> goHistory i'
            _ -> doRequestUri uri $ \item -> do
                doDefault item
                liftIO $ slurpItem item
                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'

    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 -> doRequestUri' redirs . setQuery ('?':escapeQuery 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
                    [fromId,toId] = idAtUri ais <$> [uri,uri']
                    crossScope = isJust toId && fromId /= toId
                    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 }

    extractLinksMimed :: MimedData -> [Link]
    extractLinksMimed (MimedData (MIME.Type (MIME.Text "gemini") _) body) =
        extractLinks . parseGemini $ T.decodeUtf8With T.lenientDecode body
    extractLinksMimed _ = []

    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 . (sanitiseNonCSI <$>) $ case textType of
                    "gemini" ->
                        let opts = GemRenderOpts ansi' preOpt pageWidth linkDescFirst
                        in printGemDoc opts (showUriRefFull ansi' ais uri) $ parseGemini bodyText
                    _ -> T.stripEnd <$> T.lines bodyText
        mimeType ->
            return . Left $ "No geminator for " ++ TS.unpack (MIME.showMIMEType mimeType) ++ " configured. Try \"save\", \"view\", \"!\", or \"|\"?"