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