LineClient.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020-23 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE CPP               #-}
  12 {-# LANGUAGE FlexibleContexts  #-}
  13 {-# LANGUAGE LambdaCase        #-}
  14 {-# LANGUAGE OverloadedStrings #-}
  15 {-# LANGUAGE TupleSections     #-}
  16
  17 module LineClient (lineClient) where
  18
  19 import qualified Codec.MIME.Parse             as MIME
  20 import qualified Codec.MIME.Type              as MIME
  21 import           Control.Applicative          (Alternative, empty)
  22 import           Control.Monad                (forM_, guard, join, mplus, msum,
  23                                                mzero, unless, void, when, (<=<))
  24 import           Control.Monad.Catch          (SomeException, bracket,
  25                                                displayException, handle)
  26 import           Control.Monad.IO.Class       (MonadIO, liftIO)
  27 import           Control.Monad.State          (get, gets, lift, modify)
  28 import           Control.Monad.Trans.Maybe    (MaybeT (..), runMaybeT)
  29
  30 import           Data.Bifunctor               (second)
  31 import qualified Data.ByteString.Lazy         as BL
  32 import           Data.Char                    (toLower)
  33 import           Data.Hashable                (hash)
  34 import           Data.IORef                   (modifyIORef, newIORef, readIORef)
  35 import           Data.List                    (intercalate, isPrefixOf,
  36                                                isSuffixOf, sort, stripPrefix)
  37 import qualified Data.Map                     as M
  38 import           Data.Maybe
  39 import qualified Data.Set                     as S
  40 import qualified Data.Text                    as TS
  41 import qualified Data.Text.Encoding.Error     as T
  42 import qualified Data.Text.Lazy               as T
  43 import qualified Data.Text.Lazy.Encoding      as T
  44 import qualified Data.Text.Lazy.IO            as T
  45
  46 import           Safe
  47 import qualified System.Console.Haskeline     as HL
  48 import qualified System.Console.Terminal.Size as Size
  49 import           System.Directory
  50 import           System.Environment
  51 import           System.FilePath
  52 import           System.IO.Unsafe             (unsafeInterleaveIO)
  53
  54 import           Text.Regex                   (matchRegex, mkRegexWithOpts)
  55 import           Time.System                  (timeCurrentP)
  56
  57 import           ActiveIdentities
  58 import           Alias
  59 import           ANSIColour
  60 import qualified BStack
  61 import           ClientCert                   (KeyType (..))
  62 import           ClientOptions
  63 import           ClientState
  64 import           Command
  65 import           CommandLine
  66 import           GeminiProtocol
  67 import           History
  68 import           Identity
  69 import           Marks
  70 import           MetaString
  71 import           Mundanities
  72 import           Pager
  73 import           PrintFancy
  74 import           Prompt                       hiding (promptYN)
  75 import qualified Prompt
  76 import           Queue
  77 import           Request
  78 import           ResolveTarget
  79 import qualified RunExternal
  80 import           RunExternal                  hiding (runRestrictedIO)
  81 import           Slurp
  82 import           Target
  83 import           TextGemini
  84 import           URI
  85 import           Util
  86
  87 #ifdef ICONV
  88 import           Codec.Text.IConv             (convert)
  89 #endif
  90
  91 #ifdef MAGIC
  92 import qualified Magic
  93 #endif
  94
  95 getTermSize :: IO (Int,Int)
  96 getTermSize = do
  97     Size.Window height width <- fromMaybe (Size.Window (2^(30::Int)) 80) <$> Size.size
  98     return (height,width)
  99
 100 lineClient :: ClientOptions -> [String] -> Bool -> HL.InputT ClientM ()
 101 lineClient cOpts@ClientOptions{ cOptUserDataDir = userDataDir
 102         , cOptInteractive = interactive, cOptAnsi = ansi, cOptGhost = ghost} initialCommands repl = do
 103     (liftIO . readFileLines $ userDataDir </> "diohscrc") >>= mapM_ (handleLine' . T.unpack)
 104     lift addToQueuesFromFiles
 105     mapM_ handleLine' initialCommands
 106     when repl lineClient'
 107     unless ghost $ lift appendQueuesToFiles
 108     where
 109     handleLine' :: String -> HL.InputT ClientM Bool
 110     handleLine' line = lift get >>= \s -> handleLine cOpts s line
 111
 112     lineClient' :: HL.InputT ClientM ()
 113     lineClient' = do
 114         cmd <- lift getPrompt >>= promptLineInputT
 115         quit <- case cmd of
 116             Nothing -> if interactive
 117                 then printErrFancy ansi "Use \"quit\" to quit" >> return False
 118                 else return True
 119             Just Nothing -> return True
 120             Just (Just line) -> handleLine' line
 121         lift addToQueuesFromFiles
 122         unless quit lineClient'
 123
 124     addToQueuesFromFiles :: ClientM ()
 125     addToQueuesFromFiles | ghost = return ()
 126         | otherwise = do
 127             qfs <- ignoreIOErr $ liftIO findQueueFiles
 128             forM_ qfs $ \(qfile, qname) ->
 129                 modifyQueues . enqueue (QueueSpec qname Nothing) <=<
 130                     ignoreIOErr . liftIO $
 131                     mapMaybe queueLine <$> readFileLines qfile <* removeFile qfile
 132             ignoreIOErr . liftIO $ removeDirectory queuesDir
 133         where
 134         findQueueFiles :: IO [(FilePath,String)]
 135         findQueueFiles = do
 136             qf <- (\e -> [(queueFile, "") | e]) <$> doesFileExist queueFile
 137             qfs <- ((\qn -> (queuesDir </> qn, qn)) <$>) <$> listDirectory queuesDir
 138             return $ qf <> qfs
 139         queueLine :: T.Text -> Maybe QueueItem
 140         queueLine s = QueueURI Nothing <$> (parseUriAsAbsolute . escapeIRI $ T.unpack s)
 141
 142     appendQueuesToFiles :: ClientM ()
 143     appendQueuesToFiles = do
 144         queues <- gets $ M.toList . clientQueues
 145         liftIO $ createDirectoryIfMissing True queuesDir
 146         liftIO $ forM_ queues appendQueue
 147         where
 148         appendQueue (_, []) = pure ()
 149         appendQueue (qname, queue) =
 150             let qfile = case qname of
 151                     "" -> queueFile
 152                     s  -> queuesDir </> s
 153             in warnIOErr $ BL.appendFile qfile .
 154                 T.encodeUtf8 . T.unlines $ T.pack . show . queueUri <$> queue
 155
 156     queueFile, queuesDir :: FilePath
 157     queueFile = userDataDir </> "queue"
 158     queuesDir = userDataDir </> "queues"
 159
 160     getPrompt :: ClientM String
 161     getPrompt = do
 162         queue <- gets $ M.findWithDefault [] "" . clientQueues
 163         curr <- gets clientCurrent
 164         proxies <- gets $ clientConfProxies . clientConfig
 165         ais <- gets clientActiveIdentities
 166         let queueStatus :: Maybe String
 167             queueStatus = guard (not $ null queue) >> return (show (length queue) ++ "~")
 168             colour = applyIf ansi . withColourStr
 169             bold = applyIf ansi withBoldStr
 170             uriStatus :: Int -> URI -> String
 171             uriStatus w uri =
 172                 let fullUriStr = stripGem $ show uri
 173                     stripGem s = fromMaybe s $ stripPrefix "gemini://" s
 174                     mIdName = (identityName <$>) $ findIdentity ais =<< requestOfProxiesAndUri proxies uri
 175                     idStr = flip (maybe "") mIdName $ \idName ->
 176                         let abbrId = length idName > 8 && length fullUriStr + 2 + length idName > w - 2
 177                         in "[" ++ (if abbrId then ".." ++ take 6 idName else idName) ++ "]"
 178                     abbrUri = length fullUriStr + length idStr > w - 2
 179                     uriFormat = colour BoldMagenta
 180                     uriStr = if abbrUri
 181                         then
 182                             let abbrUriChars = w - 4 - length idStr
 183                                 preChars = abbrUriChars `div` 2
 184                                 postChars = abbrUriChars - preChars
 185                             in uriFormat (take preChars fullUriStr) <>
 186                             ".." <>
 187                             uriFormat (drop (length fullUriStr - postChars) fullUriStr)
 188                         else uriFormat fullUriStr
 189                 in uriStr ++
 190                     (if null idStr then "" else colour Green idStr)
 191             prompt :: Int -> String
 192             prompt maxPromptWidth =
 193                 ((applyIf ansi withReverseStr $ colour BoldCyan "%%%") ++)
 194                     . (" " ++) . (++ bold "> ") . unwords $ catMaybes
 195                     [ queueStatus
 196                     , uriStatus (maxPromptWidth - 5 - maybe 0 ((+1) . length) queueStatus)
 197                         . historyUri <$> curr
 198                     ]
 199         prompt . min 40 . (`div` 2) . snd <$> liftIO getTermSize
 200
 201 handleLine :: ClientOptions -> ClientState -> String -> HL.InputT ClientM Bool
 202 handleLine cOpts@ClientOptions{ cOptAnsi = ansi } s line = handle backupHandler . catchInterrupts $ case parseCommandLine line of
 203     Left err -> printErrFancy ansi err >> return False
 204     Right (CommandLine Nothing (Just (c,_))) | c `isPrefixOf` "quit" -> return True
 205     Right cline -> handleCommandLine cOpts s False cline >> return False
 206     where
 207     catchInterrupts = HL.handleInterrupt (printErrFancy ansi "Interrupted." >> return False) . HL.withInterrupt . lift
 208     backupHandler :: SomeException -> HL.InputT ClientM Bool
 209     backupHandler = (>> return False) . printErrFancy ansi . ("Unhandled exception: " <>) . show
 210
 211 handleCommandLine :: ClientOptions -> ClientState -> Bool -> CommandLine -> ClientM ()
 212 handleCommandLine
 213         cOpts@(ClientOptions userDataDir interactive ansi ghost restrictedMode requestContext logH)
 214         cState@(ClientState curr jumpBack cLog visited queues _ marks sessionMarks aliases
 215             (ClientConfig defaultAction proxies geminators renderFilter preOpt linkDescFirst maxLogLen maxWrapWidth confNoConfirm verboseConnection))
 216         blockGo
 217     = \(CommandLine mt mcas) -> case mcas of
 218         Just (c,args) | Just (Alias _ (CommandLine mt' mcas')) <- lookupAlias c aliases ->
 219             let mcas'' = (, drop 1 args) . commandArgArg <$> headMay args
 220                 appendCArgs (c',as') = (c', (appendTail <$> as') ++ args)
 221                     where
 222                     appendTail arg@(CommandArg a' t') = case args of
 223                         []                   -> arg
 224                         (CommandArg _ t : _) -> CommandArg a' $ t' <> " " <> t
 225             in handleCommandLine' (mt' `mplus` mt) $
 226                 (appendCArgs <$> mcas') `mplus` mcas''
 227         _ -> handleCommandLine' mt mcas
 228
 229     where
 230
 231     -- Remark: we handle haskell's "configurations problem" by having the below all within the scope
 232     -- of the ClientOptions parameter. This is nicer to my mind than the heavier approaches of
 233     -- simulating global variables or threading a Reader monad throughout. The downside is that this
 234     -- module can't be split as much as it ought to be.
 235     -- Similar remarks go for `GeminiProtocol.makeRequest`.
 236
 237     onRestriction :: IO ()
 238     onRestriction = printErr "This is not allowed in restricted mode."
 239
 240     doRestricted :: Monoid a => RestrictedIO a -> IO a
 241     doRestricted m | restrictedMode = onRestriction >> return mempty
 242         | otherwise = RunExternal.runRestrictedIO m
 243
 244     doRestrictedAlt :: Alternative f => RestrictedIO (f a) -> IO (f a)
 245     doRestrictedAlt m | restrictedMode = onRestriction >> return empty
 246         | otherwise = RunExternal.runRestrictedIO m
 247
 248     doRestrictedFilter :: (a -> RestrictedIO a) -> (a -> IO a)
 249     doRestrictedFilter f | restrictedMode = \a -> do
 250             onRestriction
 251             return a
 252         | otherwise = RunExternal.runRestrictedIO . f
 253
 254     printErr, printInfo :: MonadIO m => String -> m ()
 255     printErr = printErrFancy ansi
 256     printInfo = printInfoFancy ansi
 257
 258     printIOErr :: IOError -> IO ()
 259     printIOErr = printErr . show
 260
 261     noConfirm :: Bool
 262     noConfirm = confNoConfirm || not interactive
 263
 264     confirm :: Applicative m => m Bool -> m Bool
 265     confirm | noConfirm = const $ pure True
 266         | otherwise = id
 267
 268     promptYN = Prompt.promptYN interactive
 269
 270     colour :: MetaString a => Colour -> a -> a
 271     colour = applyIf ansi . withColourStr
 272     bold :: MetaString a => a -> a
 273     bold = applyIf ansi withBoldStr
 274
 275     isVisited :: URI -> Bool
 276     isVisited uri = S.member (hash . T.pack $ show uri) visited
 277
 278     requestOfUri = requestOfProxiesAndUri proxies
 279
 280     idAtUri :: ActiveIdentities -> URI -> Maybe Identity
 281     idAtUri ais uri = findIdentity ais =<< requestOfUri uri
 282
 283     showUriRefFull :: MetaString a => Bool -> ActiveIdentities -> URI -> URIRef -> a
 284     showUriRefFull ansi' ais base ref = showUriFull ansi' ais (Just base) $ relativeTo ref base
 285
 286     showUriFull :: MetaString a => Bool -> ActiveIdentities -> Maybe URI -> URI -> a
 287     showUriFull ansi' ais base uri =
 288         let scheme = uriScheme uri
 289             handled = scheme `elem` ["gemini","file"] || M.member scheme proxies
 290             inHistory = isJust $ curr >>= flip pathItemByUri uri
 291             activeId = isJust $ idAtUri ais uri
 292             col = if inHistory && not activeId then BoldBlue else case (isVisited uri,handled) of
 293                 (True,True)   -> Yellow
 294                 (False,True)  -> BoldYellow
 295                 (True,False)  -> Red
 296                 (False,False) -> BoldRed
 297             s = case base of
 298                 Nothing -> show uri
 299                 Just b  -> show $ relativeFrom uri b
 300         in fromString (applyIf ansi' (withColourStr col) s) <> case idAtUri ais uri of
 301             Nothing    -> ""
 302             Just ident -> showIdentity ansi' ident
 303
 304     displayUri :: MetaString a => URI -> a
 305     displayUri = colour Yellow . fromString . show
 306
 307     showUri :: URI -> ClientM ()
 308     showUri uri = do
 309         ais <- gets clientActiveIdentities
 310         liftIO . putStrLn $ showUriFull ansi ais Nothing uri
 311
 312     addToLog :: URI -> ClientM ()
 313     addToLog uri = do
 314         let t = T.pack $ show uri
 315         modify $ \s -> s
 316             { clientLog = BStack.push maxLogLen t $ clientLog s
 317             , clientVisited = S.insert (hash . T.pack $ show uri) $ clientVisited s }
 318         unless ghost . liftIO $ maybe (return ()) (ignoreIOErr . (`T.hPutStrLn` t)) logH
 319
 320     preprocessQuery :: String -> ClientM String
 321     preprocessQuery = (escapeQuery <$>) . liftIO . maybeEdit
 322         where
 323             maybeEdit :: String -> IO String
 324             maybeEdit s | lastMay s == Just '\\' =
 325                 handle (\e -> printIOErr e >> pure s)
 326                     . doRestrictedFilter (editInteractively ansi userDataDir)
 327                     $ init s
 328             maybeEdit s = pure s
 329
 330     expand :: String -> String
 331     expand = expandHelp ansi (fst <$> aliases) userDataDir
 332
 333     idsPath = userDataDir </> "identities"
 334     savesDir = userDataDir </> "saves"
 335     marksDir = userDataDir </> "marks"
 336
 337     historyEnv :: HistoryItem -> ClientM [(String,String)]
 338     historyEnv item = gets clientActiveIdentities >>= \ais -> pure $
 339         [ ("URI", show $ historyUri item)
 340         , ("MIMETYPE", showMimeType $ historyMimedData item) ] <>
 341         (maybe [] (identityEnvironment idsPath) . idAtUri ais $ historyUri item)
 342
 343     setMark :: String -> URIWithIdName -> ClientM ()
 344     setMark mark uriId | markNameValid mark = do
 345         modify $ \s -> s { clientMarks = insertMark mark uriId $ clientMarks s }
 346         unless (mark `elem` tempMarks) . liftIO .
 347             handle printIOErr $ saveMark marksDir mark uriId
 348     setMark mark _ = printErr $ "Invalid mark name " ++ mark
 349
 350     promptInput = if ghost then promptLine else promptLineWithHistoryFile inputHistPath
 351         where inputHistPath = userDataDir </> "inputHistory"
 352
 353     handleCommandLine' :: Maybe PTarget -> Maybe (String, [CommandArg]) -> ClientM ()
 354     handleCommandLine' mt mcas = void . runMaybeT $ do
 355         ts <- case mt of
 356             Nothing -> return []
 357             Just pt -> either ((>> mzero) . printErr)
 358                 (\ts -> mapM_ addTargetId ts >> return ts) $
 359                 resolveTarget cState pt
 360         case mcas of
 361             Nothing -> lift $ handleBareTargets ts
 362             Just (s,as) -> do
 363                 c' <- maybe (printErr (unknownCommand s) >> mzero)
 364                     return $ normaliseCommand s
 365                 lift $ handleCommand ts (c',as)
 366         where
 367         unknownCommand s = "Unknown command \"" <> s <> "\". Type \"help\" for help."
 368         addTargetId :: Target -> MaybeT ClientM ()
 369         addTargetId (TargetIdUri idName uri) =
 370             liftIO (loadIdentity idsPath idName) >>= (\case
 371                 (Nothing, _) -> printErr ("Bad URI: " ++ show uri) >> mzero
 372                 (_, Nothing) -> printErr ("Unknown identity: " ++ showIdentityName ansi idName) >> mzero
 373                 (Just req, Just ident) -> lift $ addIdentity req ident) . (requestOfUri uri,)
 374         addTargetId _ = return ()
 375
 376     doPage :: [T.Text] -> ClientM ()
 377     doPage ls
 378         | interactive = do
 379             (height,width) <- liftIO getTermSize
 380             let pageWidth = min maxWrapWidth (width - 4)
 381                 perPage = height - min 3 (height `div` 4)
 382                 doCmd str = get >>= \s -> doSubCommand s True str
 383             printLinesPaged pageWidth width perPage doCmd ls
 384         | otherwise = liftIO $ mapM_ T.putStrLn ls
 385
 386     handleBareTargets :: [Target] -> ClientM ()
 387     handleBareTargets [] = return ()
 388     handleBareTargets (_:_:_) =
 389         printErr "Can only go to one place at a time. Try \"show\" or \"page\"?"
 390     handleBareTargets [TargetHistory item] = goHistory item
 391     handleBareTargets [TargetFrom origin uri] = goUri False (Just origin) uri
 392     handleBareTargets [t] = goUri False Nothing $ targetUri t
 393
 394
 395     handleCommand :: [Target] -> (String, [CommandArg]) -> ClientM ()
 396     handleCommand _ (c,_) | restrictedMode && notElem c (commands True) =
 397         printErr "Command disabled in restricted mode"
 398     handleCommand [] ("help", args) = case args of
 399         []                 -> doPage . map (T.pack . expand) $ helpText
 400         CommandArg s _ : _ -> doPage . map (T.pack . expand) $ helpOn s
 401     handleCommand [] ("commands",_) = doPage $ T.pack . expand <$> commandHelpText
 402         where
 403         commandHelpText = ["Aliases:"] ++ (showAlias <$> aliases) ++
 404             ["","Commands:"] ++ (('{' :) . (<> "}") <$> commands False)
 405         showAlias (a, Alias s _) = "{" <> a <> "}: " <> s
 406
 407     handleCommand [] ("mark", []) =
 408         let ms = M.toAscList marks
 409             markLine (m, Just uriId) = let m' = showMinPrefix ansi (fst <$> ms) m
 410                 in T.pack $ "'" <> m' <>
 411                     replicate (max 1 $ 16 - visibleLength (T.pack m')) ' ' <>
 412                     showUriWithId uriId
 413             markLine (m, Nothing) = T.pack $ "'" <> m <> " [Failed to read mark]"
 414         in doPage $ markLine <$> ms
 415     handleCommand [] ("inventory",_) = do
 416         ais <- gets clientActiveIdentities
 417         let showNumberedUri :: Bool -> T.Text -> (Int,URI) -> T.Text
 418             showNumberedUri iter s (n,uri) = s <>
 419                 (if iter && n == 1 then " "
 420                     else if iter && n == 2 then T.takeEnd 1 s
 421                     else T.pack (show n)) <>
 422                 " " <> showUriFull ansi ais Nothing uri
 423             showIteratedItem s (n,item) = showNumberedUri True s (n, historyUri item)
 424             showNumberedItem s (n,item) = showNumberedUri False s (n, historyUri item)
 425             showIteratedQueueItem s (n, QueueURI _ uri) =
 426                 showNumberedUri True s (n, uri)
 427             showIteratedQueueItem s (n, QueueHistory item) =
 428                 showNumberedUri True s (n, historyUri item) <> " {fetched}"
 429             showJumpBack :: [T.Text]
 430             showJumpBack = maybeToList $ ("'' " <>) . showUriFull ansi ais Nothing . historyUri <$> jumpBack
 431         doPage . intercalate [""] . filter (not . null) $
 432             showJumpBack :
 433             [ showIteratedQueueItem (T.pack $ qname <> "~") <$> zip [1..] queue
 434                 | (qname, queue) <- M.toList queues ]
 435             ++ [ showNumberedItem "'" <$> M.toAscList sessionMarks
 436             , (showIteratedItem "<" <$> zip [1..] (maybe [] (initSafe . historyAncestors) curr))
 437             ++ (("@  " <>) . showUriFull ansi ais Nothing . historyUri <$>
 438                 maybeToList (curr >>= lastMay . historyAncestors))
 439             , showIteratedItem ">" <$> zip [1..] (maybe [] historyDescendants curr)
 440             ]
 441     handleCommand [] ("log",_) =
 442         let showLog (n,t) = "$" <> T.pack (show n) <> " " <> colour Yellow t
 443         in doPage $ showLog <$> zip [(1::Int)..] (BStack.toList cLog)
 444     handleCommand [] ("alias", CommandArg a _ : CommandArg _ str : _) = void . runMaybeT $ do
 445         c <- either ((>>mzero) . printErr) return $ parseCommand a
 446         when (c /= a) $ printErr ("Bad alias: " <> a) >> mzero
 447         cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
 448         modify $ \s ->
 449                 s { clientAliases = insertAlias a (Alias str cl) . deleteAlias a $ clientAliases s }
 450     handleCommand [] ("alias", [CommandArg a _]) =
 451         modify $ \s -> s { clientAliases = deleteAlias a $ clientAliases s }
 452     handleCommand [] ("set", []) = liftIO $ do
 453         let (c,args) = defaultAction
 454         putStrLn $ expand "{default_action}: " <> c <>
 455             maybe "" ((" "<>) . commandArgLiteralTail) (headMay args)
 456         putStrLn $ expand "{proxies}:"
 457         printMap showHost $ M.toAscList proxies
 458         putStrLn $ expand "{geminators}:"
 459         printMap id $ second snd <$> geminators
 460         putStrLn $ expand "{render_filter}: " <> fromMaybe "" renderFilter
 461         putStrLn $ expand "{pre_display}: " <> showPreOpt preOpt
 462         putStrLn $ expand "{link_desc_first}: " <> show linkDescFirst
 463         putStrLn $ expand "{log_length}: " <> show maxLogLen
 464         putStrLn $ expand "{max_wrap_width}: " <> show maxWrapWidth
 465         putStrLn $ expand "{no_confirm}: " <> show noConfirm
 466         putStrLn $ expand "{verbose_connection}: " <> show verboseConnection
 467         where
 468             printMap :: (a -> String) -> [(String,a)] -> IO ()
 469             printMap f as = mapM_ putStrLn $
 470                 (\(k,e) -> "  " <> k <> " " <> f e) <$> as
 471     handleCommand [] ("set", CommandArg opt _ : val)
 472         | opt `isPrefixOf` "default_action" = case val of
 473             (CommandArg cmd _ : args) -> case actionOfCommand (cmd,args) of
 474                 Just _ -> modifyCConf $ \c -> c { clientConfDefaultAction = (cmd,args) }
 475                 Nothing -> printErr "Invalid action"
 476             _ -> printErr "Require value for option."
 477         | opt `isPrefixOf` "proxies" || opt `isPrefixOf` "proxy" = case val of
 478             (CommandArg scheme _ : val') ->
 479                 let f = maybe (M.delete scheme) (M.insert scheme) $
 480                         parseHost . commandArgLiteralTail =<< headMay val'
 481                 in modifyCConf $ \c -> c { clientConfProxies = f $ clientConfProxies c }
 482                     -- if only I'd allowed myself to use lenses, eh?
 483             [] -> printErr "Require mimetype to set geminator for."
 484         | opt `isPrefixOf` "geminators" = case val of
 485             (CommandArg patt _ : val') ->
 486                 let f = maybe (filter $ (/= patt) . fst)
 487                         (\v -> (++ [(patt, (mkRegexWithOpts patt True True,
 488                             commandArgLiteralTail v))])) $
 489                         headMay val'
 490                 in modifyCConf $ \c -> c { clientConfGeminators = f $ clientConfGeminators c }
 491             [] -> printErr "Require mimetype to set geminator for."
 492         | opt `isPrefixOf` "render_filter" =
 493             modifyCConf $ \c -> c { clientConfRenderFilter =
 494                 commandArgLiteralTail <$> headMay val }
 495         | opt `isPrefixOf` "pre_display" = case val of
 496             [CommandArg s _] | map toLower s `isPrefixOf` "both" ->
 497                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptBoth }
 498             [CommandArg s _] | map toLower s `isPrefixOf` "pre" ->
 499                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptPre }
 500             [CommandArg s _] | map toLower s `isPrefixOf` "alt" ->
 501                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptAlt }
 502             _ -> printErr "Require \"both\" or \"pre\" or \"alt\" for pre_display"
 503         | opt `isPrefixOf` "link_desc_first" = case val of
 504             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 505                 modifyCConf $ \c -> c { clientConfLinkDescFirst = True }
 506             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 507                 modifyCConf $ \c -> c { clientConfLinkDescFirst = False }
 508             _ -> printErr "Require \"true\" or \"false\" as value for link_desc_first"
 509         | opt `isPrefixOf` "log_length" = case val of
 510             [CommandArg s _] | Just n <- readMay s, n >= 0 -> do
 511                 modifyCConf $ \c -> c { clientConfMaxLogLen = n }
 512                 modify $ \st -> st { clientLog = BStack.truncate n $ clientLog st }
 513             _ -> printErr "Require non-negative integer value for log_length"
 514         | opt `isPrefixOf` "max_wrap_width" = case val of
 515             [CommandArg s _] | Just n <- readMay s, n > 0 ->
 516                 modifyCConf $ \c -> c { clientConfMaxWrapWidth = n }
 517             _ -> printErr "Require positive integer value for max_wrap_width"
 518         | opt `isPrefixOf` "no_confirm" = case val of
 519             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 520                 modifyCConf $ \c -> c { clientConfNoConfirm = True }
 521             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 522                 modifyCConf $ \c -> c { clientConfNoConfirm = False }
 523             _ -> printErr "Require \"true\" or \"false\" as value for no_confirm"
 524         | opt `isPrefixOf` "verbose_connection" = case val of
 525             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 526                 modifyCConf $ \c -> c { clientConfVerboseConnection = True }
 527             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 528                 modifyCConf $ \c -> c { clientConfVerboseConnection = False }
 529             _ -> printErr "Require \"true\" or \"false\" as value for verbose_connection"
 530         | otherwise = printErr $ "No such option \"" <> opt <> "\"."
 531     handleCommand [] cargs =
 532         case curr of
 533             Just item -> handleCommand [TargetHistory item] cargs
 534             Nothing -> printErr "No current location. Enter an URI, or type \"help\"."
 535
 536     handleCommand ts ("add", args) = case parseQueueSpec $ commandArgArg <$> args of
 537         Nothing -> printErr "Bad arguments to 'add'."
 538         Just qs -> modifyQueues . enqueue qs $ targetQueueItem <$> ts
 539
 540     handleCommand ts ("fetch", args) = case parseQueueSpec $ commandArgArg <$> args of
 541         Nothing -> printErr "Bad arguments to 'fetch."
 542         Just qs -> do
 543             -- XXX: we have to use an IORef to store the items, since
 544             -- CommandAction doesn't allow a return value.
 545             lRef <- liftIO $ newIORef []
 546             let add item = liftIO $ slurpItem item >> modifyIORef lRef (item:)
 547             forM_ ts $ \t -> case t of
 548                 TargetHistory item -> add item
 549                 _ -> modifyQueues (unqueue uri) >> doRequestUri uri add
 550                     where uri = targetUri t
 551             l <- liftIO $ reverse <$> readIORef lRef
 552             modifyQueues . enqueue qs $ QueueHistory <$> l
 553
 554     handleCommand ts cargs =
 555         mapM_ handleTargetCommand ts
 556         where
 557         handleTargetCommand (TargetHistory item) | Just action <- actionOfCommand cargs =
 558             action item
 559         handleTargetCommand t | Just action <- actionOfCommand cargs =
 560             let uri = targetUri t
 561             in modifyQueues (unqueue uri) >> doRequestUri uri action
 562         handleTargetCommand (TargetHistory item) | ("repeat",_) <- cargs =
 563             goUri True (recreateOrigin <$> historyParent item) $ historyUri item
 564         handleTargetCommand (TargetHistory item) | ("repl",_) <- cargs =
 565             repl (recreateOrigin <$> historyParent item) $ historyUri item
 566         handleTargetCommand t | ("query", CommandArg _ str : _) <- cargs = do
 567             let origin = case t of
 568                     TargetHistory item -> Just $ HistoryOrigin item Nothing
 569                     TargetFrom o _     -> Just o
 570                     _                  -> Nothing
 571             str' <- preprocessQuery str
 572             goUri True origin . setQuery ('?':str') $ targetUri t
 573         handleTargetCommand t =
 574             handleUriCommand (targetUri t) cargs
 575
 576         recreateOrigin :: HistoryItem -> HistoryOrigin
 577         recreateOrigin parent = HistoryOrigin parent $ childLink =<< historyChild parent
 578
 579         handleUriCommand uri ("delete",[]) =
 580             modifyQueues $ unqueueFrom "" uri
 581         handleUriCommand uri ("delete",CommandArg qname _ : _) =
 582             modifyQueues $ unqueueFrom qname uri
 583         handleUriCommand uri ("repeat",_) = goUri True Nothing uri
 584         handleUriCommand uri ("uri",_) = showUri uri
 585         handleUriCommand uri ("mark", CommandArg mark _ : _)
 586             | Just _ <- readMay mark :: Maybe Int = error "Bad mark for uri"
 587             | otherwise = do
 588             ais <- gets clientActiveIdentities
 589             let mIdName = case findIdentity ais =<< requestOfUri uri of
 590                     Just ident | not $ isTemporary ident -> Just $ identityName ident
 591                     _ -> Nothing
 592             setMark mark $ URIWithIdName uri mIdName
 593         handleUriCommand uri ("identify", args) = case requestOfUri uri of
 594             Nothing -> printErr "Bad URI"
 595             Just req -> gets ((`findIdentityRoot` req) . clientActiveIdentities) >>= \case
 596                 Just (root,(ident,_)) | null args -> endIdentityPrompted root ident
 597                 _ -> void . runMaybeT $ do
 598                     ident <- MaybeT . liftIO $ case args of
 599                         CommandArg idName _ : args' ->
 600                             let tp = case args' of
 601                                     CommandArg ('e':'d':_) _ : _ -> KeyEd25519
 602                                     _                            -> KeyRSA
 603                             in getIdentity interactive ansi idsPath tp idName
 604                         [] -> if interactive
 605                             then getIdentityRequesting ansi idsPath
 606                             else getIdentity interactive ansi idsPath KeyRSA ""
 607                     lift $ addIdentity req ident
 608         handleUriCommand uri ("browse", args) = do
 609             ais <- gets clientActiveIdentities
 610             let envir = maybe [] (identityEnvironment idsPath) .
 611                     idAtUri ais . setSchemeDefault $ uri
 612             void . liftIO . runMaybeT $ do
 613                 cmd <- case args of
 614                     [] -> maybe notSet
 615                         (\s -> if null s then notSet else return $ parseBrowser s) =<<
 616                             lift (lookupEnv "BROWSER")
 617                         where
 618                         notSet = printErr "Please set $BROWSER or give a command to run" >> mzero
 619                         -- |based on specification for $BROWSER in 'man 1 man'
 620                         parseBrowser :: String -> String
 621                         parseBrowser = subPercentOrAppend (show uri) . takeWhile (/=':')
 622                     (CommandArg _ c : _) -> return $ subPercentOrAppend (show uri) c
 623                 lift $ confirm (confirmShell "Run" cmd) >>? doRestricted $ void (runShellCmd cmd envir)
 624         handleUriCommand uri ("repl",_) = repl Nothing uri
 625         handleUriCommand uri ("log",_) = addToLog uri >> modifyQueues (unqueue uri)
 626
 627         handleUriCommand _ (c,_) = printErr $ "Bad arguments to command " <> c
 628
 629         repl :: Maybe HistoryOrigin -> URI -> ClientM ()
 630         repl origin uri = repl' where
 631             repl' = liftIO (join <$> promptInput ">> ") >>= \case
 632                 Nothing -> return ()
 633                 Just query -> do
 634                     query' <- preprocessQuery query
 635                     goUri True origin . setQuery ('?':query') $ uri
 636                     repl'
 637
 638     slurpItem :: HistoryItem -> IO ()
 639     slurpItem item = slurpNoisily (historyRequestTime item) . mimedBody $ historyMimedData item
 640
 641     actionOnRendered :: Bool -> ([T.Text] -> ClientM ()) -> CommandAction
 642     actionOnRendered ansi' m item = do
 643         ais <- gets clientActiveIdentities
 644         liftIO (renderMimed ansi' (historyUri item) ais (historyGeminatedMimedData item)) >>=
 645             either printErr m
 646
 647     actionOfCommand :: (String, [CommandArg]) -> Maybe CommandAction
 648     actionOfCommand (c,_) | restrictedMode && notElem c (commands True) = Nothing
 649     actionOfCommand ("show",_) = Just . actionOnRendered ansi $ liftIO . mapM_ T.putStrLn
 650     actionOfCommand ("page",_) = Just $ actionOnRendered ansi doPage
 651     actionOfCommand ("links",_) = Just $ \item -> do
 652         ais <- gets clientActiveIdentities
 653         let cl = childLink =<< historyChild item
 654             linkLine n (Link uri desc) =
 655                 applyIf (cl == Just (n-1)) (bold "* " <>) $
 656                 T.pack ('[' : show n ++ "] ")
 657                     <> showUriRefFull ansi ais (historyUri item) uri
 658                     <> if T.null desc then "" else " " <>
 659                         applyIf ansi (withColourStr Cyan) desc
 660         doPage . zipWith linkLine [1..] . historyLinks $ item
 661
 662     actionOfCommand ("mark", CommandArg mark _ : _) |
 663         Just n <- readMay mark :: Maybe Int = Just $ \item -> do
 664             liftIO $ slurpItem item
 665             modify $ \s -> s { clientSessionMarks = M.insert n item $ clientSessionMarks s }
 666     actionOfCommand ("mime",_) = Just $ liftIO . putStrLn . showMimeType . historyMimedData
 667     actionOfCommand ("save", []) = actionOfCommand ("save", [CommandArg "" savesDir])
 668     actionOfCommand ("save", CommandArg _ path : _) = Just $ \item -> liftIO . doRestricted . RestrictedIO $ do
 669         createDirectoryIfMissing True savesDir
 670         homePath <- getHomeDirectory
 671         let path'
 672                 | take 2 path == "~/" = homePath </> drop 2 path
 673                 | take 1 path == "/" || take 2 path == "./" || take 3 path == "../" = path
 674                 | otherwise = savesDir </> path
 675             body = mimedBody $ historyMimedData item
 676             uri = historyUri item
 677             name = fromMaybe (fromMaybe "" $ uriRegName uri) . lastMay .
 678                 filter (not . null) $ pathSegments uri
 679         handle printIOErr . void . runMaybeT $ do
 680             lift $ mkdirhierto path'
 681             isDir <- lift $ doesDirectoryExist path'
 682             let fullpath = if isDir then path' </> name else path'
 683             lift (doesDirectoryExist fullpath) >>? do
 684                 lift . printErr $ "Path " ++ show fullpath ++ " exists and is directory"
 685                 mzero
 686             lift (doesFileExist fullpath) >>?
 687                 guard =<< lift (promptYN False $ "Overwrite " ++ show fullpath ++ "?")
 688             lift $ do
 689                 putStrLn $ "Saving to " ++ fullpath
 690                 t0 <- timeCurrentP
 691                 BL.writeFile fullpath =<< interleaveProgress t0 body
 692
 693     actionOfCommand ("!", CommandArg _ cmd : _) = Just $ \item -> do
 694         env <- historyEnv item
 695         liftIO . handle printIOErr . doRestricted .
 696             shellOnData noConfirm cmd userDataDir env . mimedBody $ historyMimedData item
 697
 698     actionOfCommand ("view",_) = Just $ \item ->
 699         let mimed = historyMimedData item
 700             mimetype = showMimeType mimed
 701             body = mimedBody mimed
 702         in liftIO . handle printIOErr . doRestricted $ runMailcap noConfirm "view" userDataDir mimetype body
 703     actionOfCommand ("|", CommandArg _ cmd : _) = Just $ \item -> do
 704         env <- historyEnv item
 705         liftIO . handle printIOErr . doRestricted $
 706             pipeToShellLazily cmd env . mimedBody $ historyMimedData item
 707     actionOfCommand ("||", args) = Just $ pipeRendered ansi args
 708     actionOfCommand ("||-", args) = Just $ pipeRendered False args
 709     actionOfCommand ("cat",_) = Just $ liftIO . BL.putStr . mimedBody . historyMimedData
 710     actionOfCommand ("at", CommandArg _ str : _) = Just $ \item ->
 711         doSubCommand (cState { clientCurrent = Just item }) blockGo str
 712     actionOfCommand _ = Nothing
 713
 714     pipeRendered :: Bool -> [CommandArg] -> CommandAction
 715     pipeRendered ansi' args item = (\action -> actionOnRendered ansi' action item) $ \ls -> do
 716         env <- historyEnv item
 717         liftIO . void . runMaybeT $ do
 718             cmd <- case args of
 719                 [] -> maybe notSet
 720                     (\s -> if null s then notSet else return s) =<<
 721                     liftIO (lookupEnv "PAGER")
 722                     where
 723                     notSet = printErr "Please set $PAGER or give a command to run" >> mzero
 724                 (CommandArg _ cmd : _) -> return cmd
 725             lift . doRestricted . pipeToShellLazily cmd env . T.encodeUtf8 $ T.unlines ls
 726
 727     doSubCommand :: ClientState -> Bool -> String -> ClientM ()
 728     doSubCommand s block str = void . runMaybeT $ do
 729         cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
 730         lift $ handleCommandLine cOpts s block cl
 731
 732     setCurr :: HistoryItem -> ClientM ()
 733     setCurr i =
 734         let isJump = isNothing $ curr >>= pathItemByUri i . historyUri
 735         in do
 736             when isJump $ modify $ \s -> s { clientJumpBack = curr }
 737             modify $ \s -> s { clientCurrent = Just i }
 738
 739     doDefault :: HistoryItem -> ClientM ()
 740     doDefault item =
 741         maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction
 742
 743     goHistory :: HistoryItem -> ClientM ()
 744     goHistory _ | blockGo = printErr "Can't go anywhere now."
 745     goHistory item = do
 746         modifyQueues $ unqueue uri
 747         showUri uri
 748         setCurr item
 749         doDefault item
 750         where uri = historyUri item
 751
 752     goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM ()
 753     goUri _ _ _ | blockGo = printErr "Can't go anywhere now."
 754     goUri forceRequest origin uri = do
 755         modifyQueues $ unqueue uri
 756         activeId <- gets $ isJust . (`idAtUri` uri) . clientActiveIdentities
 757         case curr >>= flip pathItemByUri uri of
 758             Just i' | not (activeId || forceRequest) -> goHistory i'
 759             _ -> doRequestUri uri $ \item -> do
 760                 let updateParent i =
 761                         -- Lazily recursively update the links in the doubly linked list
 762                         let i' = i { historyParent = updateParent . updateChild i' <$> historyParent i }
 763                         in i'
 764                     updateChild i' i = i { historyChild = setChild <$> historyChild i }
 765                         where setChild c = c { childItem = i' }
 766                     glueOrigin (HistoryOrigin o l) = updateParent $ o { historyChild = Just $ HistoryChild item' l }
 767                     item' = item { historyParent = glueOrigin <$> origin }
 768                 setCurr item'
 769                 doDefault item
 770                 liftIO $ slurpItem item
 771
 772     doRequestUri :: URI -> CommandAction -> ClientM ()
 773     doRequestUri uri0 action = doRequestUri' 0 uri0
 774         where
 775         doRequestUri' redirs uri
 776             | Just req <- requestOfUri uri = addToLog uri >> doRequest redirs req
 777             | otherwise = printErr $ "Bad URI: " ++ displayUri uri ++ (
 778                     let scheme = uriScheme uri
 779                     in if scheme /= "gemini" && isNothing (M.lookup scheme proxies)
 780                     then " : No proxy set for non-gemini scheme " ++ scheme ++ "; use \"browse\"?"
 781                     else "")
 782
 783         doRequest :: Int -> Request -> ClientM ()
 784         doRequest redirs _ | redirs > 5 =
 785             printErr "Too many redirections!"
 786         doRequest redirs req@(NetworkRequest _ uri) = do
 787             (mId, ais) <- liftIO . useActiveIdentity noConfirm ansi req =<< gets clientActiveIdentities
 788             modify $ \s -> s { clientActiveIdentities = ais }
 789             printInfo $ ">>> " ++ showUriFull ansi ais Nothing uri
 790             let respBuffSize = 2 ^ (15::Int) -- 32KB max cache for response stream
 791             liftIO (makeRequest requestContext mId respBuffSize verboseConnection req)
 792                 `bracket` either (\_ -> return ()) (liftIO . snd) $
 793                 either
 794                     (printErr . displayException)
 795                     (handleResponse . fst)
 796             where
 797             handleResponse :: Response -> ClientM ()
 798             handleResponse (Input isPass prompt) = do
 799                 let defaultPrompt = "[" ++ (if isPass then "PASSWORD" else "INPUT") ++ "]"
 800                 (liftIO . (join <$>) . promptInput $
 801                         (if null prompt then defaultPrompt else prompt) ++ " > ") >>= \case
 802                     Nothing -> return ()
 803                     Just query -> do
 804                         query' <- preprocessQuery query
 805                         doRequestUri' redirs . setQuery ('?':query') $ uri
 806
 807             handleResponse (Success mimedData) = doAction req mimedData
 808
 809             handleResponse (Redirect isPerm to) = do
 810                 ais <- gets clientActiveIdentities
 811                 let uri' = to `relativeTo` uri
 812                     crossSite = uriRegName uri' /= uriRegName uri
 813                     crossScheme = uriScheme uri' /= uriScheme uri
 814                     crossScope = case idAtUri ais <$> [uri,uri'] of
 815                             [fromId,toId] -> isJust toId && fromId /= toId
 816                             _             -> False
 817                     warningStr = colour BoldRed
 818                 proceed <- (isJust <$>) . lift . runMaybeT $ do
 819                     when crossSite $ guard <=< (liftIO . promptYN False) $
 820                         warningStr "Follow cross-site redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
 821                     when crossScheme $ guard <=< (liftIO . promptYN False) $
 822                         warningStr "Follow cross-protocol redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
 823                     when crossScope $ guard <=< (liftIO . promptYN False) $
 824                         warningStr "Follow redirect with identity " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
 825                 when proceed $ do
 826                     when (isPerm && not ghost) . mapM_ (updateMark uri') . marksWithUri uri =<< gets clientMarks
 827                     doRequestUri' (redirs + 1) uri'
 828                 where updateMark uri' (mark,uriId) = do
 829                         conf <- confirm . liftIO . promptYN True $ "Update mark '" <> mark <> " to " <> show uri' <> " ?"
 830                         when conf . setMark mark $ uriId { uriIdUri = uri' }
 831             handleResponse (Failure code info) | 60 <= code && code <= 69 = void . runMaybeT $ do
 832                 identity <- do
 833                         liftIO . putStrLn $ (case code of
 834                             60 -> "Server requests identification"
 835                             _ -> "Server rejects provided identification certificate" ++
 836                                 (if code == 61 then " as unauthorised" else if code == 62 then " as invalid" else ""))
 837                             ++ if null info then "" else ": " ++ info
 838                         guard interactive
 839                         MaybeT . liftIO $ getIdentityRequesting ansi idsPath
 840                 lift $ do
 841                     addIdentity req identity
 842                     doRequest redirs req
 843
 844             handleResponse (Failure code info) =
 845                 printErr $ "Server returns failure: " ++ show code ++ " " ++ info
 846             handleResponse (MalformedResponse malformation) =
 847                 printErr $ "Malformed response from server: " ++ show malformation
 848
 849         doRequest redirs (LocalFileRequest path) | redirs > 0 = printErr "Ignoring redirect to local file."
 850             | otherwise = void . runMaybeT $ do
 851                 (path', mimedData) <- MaybeT . liftIO . doRestrictedAlt . RestrictedIO . warnIOErrAlt $ do
 852                     let detectExtension = case takeExtension path of
 853                             -- |certain crucial filetypes we can't rely on magic to detect:
 854                             s | s `elem` [".gmi", ".gem", ".gemini"] -> Just "text/gemini"
 855                             ".md" -> Just "text/markdown"
 856                             ".html" -> Just "text/html"
 857                             _ -> Nothing
 858 #ifdef MAGIC
 859                         detectPlain "text/plain" = fromMaybe "text/plain" detectExtension
 860                         detectPlain s = s
 861                     magic <- Magic.magicOpen [Magic.MagicMimeType]
 862                     Magic.magicLoadDefault magic
 863                     s <- detectPlain <$> Magic.magicFile magic path
 864 #else
 865                     let s = if "/" `isSuffixOf` path then "inode/directory"
 866                             else fromMaybe "application/octet-stream" detectExtension
 867 #endif
 868                     case MIME.parseMIMEType $ TS.pack s of
 869                         Nothing -> printErr ("Failed to parse mimetype string: " <> s) >> return Nothing
 870                         _ | s == "inode/directory" -> Just . (slashedPath,) . MimedData gemTextMimeType .
 871                             T.encodeUtf8 . T.unlines .
 872                             ((("=> " <>) . T.pack . escapePathString) <$>) . sort <$>
 873                                 getDirectoryContents path
 874                             where slashedPath | "/" `isSuffixOf` path = path
 875                                     | otherwise = path <> "/"
 876                         Just mimetype -> Just . (path,) . MimedData mimetype <$> BL.readFile path
 877                 lift $ doAction (LocalFileRequest path') mimedData
 878
 879         doAction req mimedData = do
 880             t0 <- liftIO timeCurrentP
 881             geminated <- geminate mimedData
 882             action $ HistoryItem req t0 mimedData geminated Nothing Nothing
 883             where
 884             -- |returns MimedData with lazy IO
 885             geminate :: MimedData -> ClientM MimedData
 886             geminate mimed =
 887                 let geminator = lookupGeminator $ showMimeType mimed
 888                 in liftIO . unsafeInterleaveIO $ applyGeminator geminator
 889                 where
 890                 lookupGeminator mimetype =
 891                     listToMaybe [ gem | (_, (regex, gem)) <- geminators
 892                         , isJust $ matchRegex regex mimetype ]
 893                 applyGeminator Nothing = return mimed
 894                 applyGeminator (Just cmd) =
 895                     printInfo ("| " <> cmd) >>
 896                     MimedData gemTextMimeType <$>
 897                         doRestrictedFilter (filterShell cmd [("URI", show $ requestUri req)]) (mimedBody mimed)
 898
 899         gemTextMimeType :: MIME.Type
 900         gemTextMimeType = MIME.Type (MIME.Text "gemini") []
 901
 902
 903     addIdentity :: Request -> Identity -> ClientM ()
 904     addIdentity req identity = do
 905         ais <- gets clientActiveIdentities >>= liftIO . insertIdentity req identity
 906         modify $ \s -> s {clientActiveIdentities = ais}
 907     endIdentityPrompted :: Request -> Identity -> ClientM ()
 908     endIdentityPrompted root ident = do
 909         conf <- confirm $ liftIO . promptYN False $ "Stop using " ++
 910             (if isTemporary ident then "temporary anonymous identity" else showIdentity ansi ident) ++
 911             " at " ++ displayUri (requestUri root) ++ "?"
 912         when conf . modify $ \s ->
 913                 s { clientActiveIdentities = deleteIdentity root $ clientActiveIdentities s }
 914
 915     renderMimed :: Bool -> URI -> ActiveIdentities -> MimedData -> IO (Either String [T.Text])
 916     renderMimed ansi' uri ais (MimedData mime body) = case MIME.mimeType mime of
 917         MIME.Text textType -> do
 918             let extractCharsetParam (MIME.MIMEParam "charset" v) = Just v
 919                 extractCharsetParam _                            = Nothing
 920                 charset = TS.unpack . fromMaybe "utf-8" . msum . map extractCharsetParam $ MIME.mimeParams mime
 921                 isUtf8 = map toLower charset `elem` ["utf-8", "utf8"]
 922 #ifdef ICONV
 923                 reencoder = if isUtf8 then id else
 924                     convert charset "UTF-8"
 925 #else
 926                 reencoder = id
 927             unless isUtf8 . printErr $
 928                 "Warning: Treating unsupported charset " ++ show charset ++ " as utf-8"
 929 #endif
 930             (_,width) <- getTermSize
 931             let pageWidth = if interactive
 932                 then min maxWrapWidth (width - 4)
 933                 else maxWrapWidth
 934             let bodyText = T.decodeUtf8With T.lenientDecode $ reencoder body
 935                 applyFilter :: [T.Text] -> IO [T.Text]
 936                 applyFilter = case renderFilter of
 937                     Nothing -> return
 938                     Just cmd -> (T.lines . T.decodeUtf8With T.lenientDecode <$>) .
 939                         doRestrictedFilter (filterShell cmd []) . BL.concat . (appendNewline . T.encodeUtf8 <$>)
 940                         where appendNewline = (`BL.snoc` 10)
 941             (Right <$>) . applyFilter $ case textType of
 942                     "gemini" ->
 943                         let opts = GemRenderOpts ansi' preOpt pageWidth linkDescFirst
 944                         in printGemDoc opts (showUriRefFull ansi' ais uri) $ parseGemini bodyText
 945                     _ -> T.stripEnd . stripControl <$> T.lines bodyText
 946         mimeType ->
 947             return . Left $ "No geminator for " ++ TS.unpack (MIME.showMIMEType mimeType) ++ " configured. Try \"save\", \"view\", \"!\", or \"|\"?"