-- 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 FlexibleContexts, LambdaCase, OverloadedStrings, TupleSections #-}
{-# LANGUAGE CPP #-}

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 (isUpper, toLower)
import Data.Hash (Hash, hash)
import Data.List (find, intercalate, isPrefixOf, isSuffixOf, 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, mkRegexWithOpts, matchRegex)
import Time.System (timeCurrentP)
import Time.Types (ElapsedP)

import qualified Data.ByteString.Lazy as BL

import qualified Codec.MIME.Type as MIME
import qualified Codec.MIME.Parse as MIME
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as TS
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as T
import qualified Data.Text.Encoding.Error 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 ActiveIdentities
import Alias
import ANSIColour
import qualified BStack
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 Util
import Version
import URI

#ifndef WINDOWS
import System.Posix.Files (setFileMode, ownerModes)
#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
    , cOptRestrictedMode :: Bool
    , cOptGhost :: 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
    , clientConfMaxLogLen :: Int
    , clientConfMaxWrapWidth :: Int
    , clientConfNoConfirm :: Bool
    }

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

data QueueItem = QueueItem
    { queueOrigin :: Maybe HistoryOrigin
    , queueUri :: URI
    }

data ClientState = ClientState
    { clientCurrent :: Maybe HistoryItem
    , clientJumpBack :: Maybe HistoryItem
    , clientLog :: BStack.BStack T.Text
    , clientVisited :: S.Set Hash
    , clientQueue :: [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 emptyMarks M.empty defaultAliases [] defaultClientConfig

enqueue :: Maybe Int -> [QueueItem] -> ClientM ()
enqueue _ [] = return ()
enqueue after qs = modify $ \s -> s {clientQueue = insert after qs $ clientQueue s}
    where
    insert mn as bs = let (bs',bs'') = maybe (bs,[]) (`splitAt` bs) mn in del as bs' ++ as ++ del as bs''
    del as = filter $ (`notElem` (queueUri <$> as)) . queueUri

dropUriFromQueue :: URI -> ClientM ()
dropUriFromQueue uri = modify $ \s -> s { clientQueue = filter ((/= uri) . queueUri) $ clientQueue s }

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 <- makeAbsolute . 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 interactive = null optCommands || Interactive `elem` opts

    let argToUri arg = doesPathExist arg >>= \case
            True -> Just . ("file://" <>) . escapeUriString <$> makeAbsolute arg
            False | Just uri <- parseUriAsAbsolute 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

    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

    requestContext <- initRequestContext callbacks userDataDir ghost
    (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

    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
            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 25 80) <$> Size.size
    return (height,width)

lineClient :: ClientOptions -> [String] -> HL.InputT ClientM ()
lineClient cOpts@ClientOptions{ cOptUserDataDir = userDataDir
        , cOptInteractive = interactive, cOptAnsi = ansi, cOptGhost = ghost} initialCommands = do
    (liftIO . readFileLines $ userDataDir </> "diohscrc") >>= mapM_ (handleLine' . T.unpack)
    lift addToQueueFromFile
    mapM_ handleLine' initialCommands
    when interactive lineClient'
    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 c
            , MaybeT $ lift getPrompt >>= promptLineInputT ]
        lift addToQueueFromFile
        quit <- case cmd of
            Nothing -> if interactive
                then printErrOpt ansi "Use \"quit\" to quit" >> return False
                else return True
            Just line -> handleLine' line
        when (quit && not ghost) $ lift appendQueueToFile
        unless quit lineClient'

    addToQueueFromFile :: ClientM ()
    addToQueueFromFile | ghost = return ()
        | otherwise = (enqueue Nothing =<<) . liftIO . ignoreIOErr $ doesPathExist queueFile >>= \case
            True -> catMaybes . (queueLine <$>) <$> readFileLines queueFile <* removeFile queueFile
                where
                queueLine :: T.Text -> Maybe QueueItem
                queueLine s = QueueItem Nothing <$> parseUriAsAbsolute (T.unpack s)
            False -> return []

    appendQueueToFile :: ClientM ()
    appendQueueToFile = do
        queue <- gets clientQueue
        unless (null queue) . liftIO . BL.appendFile queueFile .
            T.encodeUtf8 . T.unlines $ T.pack . show . queueUri <$> queue

    queueFile :: FilePath
    queueFile = userDataDir </> "queue"

    getPrompt :: ClientM String
    getPrompt = do
        queue <- gets clientQueue
        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
                | interactive = (colour BoldCyan "%%% " ++) . (++ bold "> ") . unwords $ catMaybes
                    [ queueStatus
                    , uriStatus (maxPromptWidth - 5 - maybe 0 ((+1) . length) queueStatus) . historyUri <$> curr
                    ]
                | otherwise = ""
        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) = QueueItem (Just o) uri
targetQueueItem i = QueueItem Nothing $ targetUri i

handleCommandLine :: ClientOptions -> ClientState -> CommandLine -> ClientM ()
handleCommandLine
        cOpts@(ClientOptions userDataDir interactive ansi ghost restrictedMode requestContext logH)
        cState@(ClientState curr jumpBack cLog visited queue _ marks sessionMarks aliases _
            (ClientConfig defaultAction proxies geminators renderFilter preOpt maxLogLen maxWrapWidth confNoConfirm))
    = \(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
            col = 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 . 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 = do
        modify $ \s -> s { clientMarks = insertMark mark uriId $ clientMarks s }
        unless (mark `elem` tempMarks) . liftIO .
            handle printIOErr $ saveMark marksDir mark uriId

    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) =
            (requestOfUri 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
        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 specs) =
        (queueTarget <$>) <$> resolveElemsSpecs "queue item" (matchPatternOn $ show . queueUri) queue specs
        where
        queueTarget (QueueItem Nothing uri) = TargetUri uri
        queueTarget (QueueItem (Just o) uri) = TargetFrom o uri

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

    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 . 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 t = TargetUri . relativeTo ref $ targetUri t

    resolveTarget (PTargetAbs s) = case parseUriAsAbsolute $ 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 catMaybes . (linkTarg <$>) <$> resolveElemsSpecs "link" isMatch slice specs >>= \case
            [] -> Left "No such link"
            targs -> return targs

    matchPattern :: String -> String -> Bool
    matchPattern patt =
        let regex = mkRegexWithOpts patt True (exists isUpper patt)
            exists f = not . all (not . f)
        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)
        queued <- liftIO $ printLinesPaged pageWidth width (height - 2) ls
        modify $ \s -> s { clientQueuedCommands = clientQueuedCommands s ++ queued }
        | 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, 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 :: T.Text -> (Int,URI) -> T.Text
            showNumberedUri s (n,uri) = s <> T.pack (show n) <> " " <> showUriFull ansi ais Nothing uri
            showNumberedItem s (n,item) = showNumberedUri s (n, historyUri item)
            showNumberedQueueItem s (n,q) = showNumberedUri s (n, queueUri q)
            showJumpBack :: [T.Text]
            showJumpBack = maybeToList $ ("'' " <>) . showUriFull ansi ais Nothing . historyUri <$> jumpBack
        doPage . intercalate [""] . filter (not . null) $
            [ showJumpBack
            , showNumberedQueueItem "~" <$> zip [1..] queue
            , showNumberedItem "'" <$> M.toAscList sessionMarks
            , showNumberedItem "<" <$> zip [1..] (maybe [] historyAncestors curr)
            , showNumberedItem ">" <$> 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 "{log_length}: " <> show maxLogLen
        putStrLn $ expand "{max_wrap_width}: " <> show maxWrapWidth
        putStrLn $ expand "{no_confirm}: " <> show noConfirm
        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` "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"
        | 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) =
        enqueue (readMay . commandArgArg =<< headMay args) $ targetQueueItem <$> ts
    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 dropUriFromQueue 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 ("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,_)) -> endIdentityPrompted root ident
                Nothing -> void . runMaybeT $ do
                    ident <- MaybeT . liftIO $ case args of
                        (CommandArg idName _ : _) -> getIdentity noConfirm ansi idsPath idName
                        [] -> getIdentityRequesting ansi idsPath
                    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 ("log",_) = addToLog uri

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

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

    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 =
                applyIf (cl == Just (n-1)) (bold "* " <>) $
                    printGemLinkLine ansi (showUriRefFull ansi ais $ historyUri item) n link
        doPage . zipWith linkLine [1..] . extractLinksMimed . historyGeminatedMimedData $ item

    actionOfCommand ("mark", CommandArg mark _ : _) |
        Just n <- readMay mark :: Maybe Int = Just $ \item ->
            modify $ \s -> s { clientSessionMarks = M.insert n item $ clientSessionMarks s }
    actionOfCommand ("mime",_) = Just $ liftIO . print . 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' = if take 2 path == "~/"
                then homePath </> drop 2 path
                else savesDir </> path
            body = mimedBody $ historyMimedData item
            name = fromMaybe "" . lastMay . pathSegments $ historyUri item
        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 =<< not <$> 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 $ historyUri <$> curr >>= pathItemByUri i
        in do
            when isJump $ modify $ \s -> s { clientJumpBack = curr }
            modify $ \s -> s { clientCurrent = Just i }

    goHistory :: HistoryItem -> ClientM ()
    goHistory i = setCurr i >> showUri (historyUri i)

    goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM ()
    goUri forceRequest origin uri = dropUriFromQueue uri >> case curr >>= flip pathItemByUri uri of
        Just i' | not forceRequest -> goHistory i'
        _ -> doRequestUri uri $ \item -> do
            maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction
            liftIO . slurpNoisily (historyRequestTime item) . mimedBody $ historyMimedData 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'
            addToLog uri

    doRequestUri :: URI -> CommandAction -> ClientM ()
    doRequestUri uri0 action = doRequestUri' 0 uri0
        where
        doRequestUri' redirs uri
            | Just req <- requestOfUri 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 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") ++ "]"
                    prompter = if isPass then promptPassword else promptInput
                (liftIO . prompter $ (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
                let uri' = to `relativeTo` uri
                    crossSite = uriRegName uri' /= uriRegName uri
                    crossScheme = uriScheme uri' /= uriScheme uri
                    warningStr = colour BoldRed
                ais <- gets clientActiveIdentities
                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 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
                        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 . escapeUriString) <$>) <$>
                                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
                        in printGemDoc opts (showUriRefFull ansi' ais uri) $ parseGemini bodyText
                    _ -> T.stripEnd <$> T.lines bodyText
        mimeType ->
            return . Left $ "Display of non-text MIME type " ++ TS.unpack (MIME.showMIMEType mimeType) ++ " not supported."