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 | unescapedTerminalBlash s =
 326                 handle (\e -> printIOErr e >> pure s)
 327                     . doRestrictedFilter (editInteractively ansi userDataDir)
 328                     $ init s
 329             maybeEdit s = pure s
 330             unescapedTerminalBlash s = case take 2 $ reverse s of
 331                 [ '\\' ]       -> True
 332                 [ '\\', '\\' ] -> False
 333                 [ '\\', _ ]    -> True
 334                 _              -> False
 335
 336     expand :: String -> String
 337     expand = expandHelp ansi (fst <$> aliases) userDataDir
 338
 339     idsPath = userDataDir </> "identities"
 340     savesDir = userDataDir </> "saves"
 341     marksDir = userDataDir </> "marks"
 342
 343     historyEnv :: HistoryItem -> ClientM [(String,String)]
 344     historyEnv item = gets clientActiveIdentities >>= \ais -> pure $
 345         [ ("URI", show $ historyUri item)
 346         , ("MIMETYPE", showMimeType $ historyMimedData item) ] <>
 347         (maybe [] (identityEnvironment idsPath) . idAtUri ais $ historyUri item)
 348
 349     setMark :: String -> URIWithIdName -> ClientM ()
 350     setMark mark uriId | markNameValid mark = do
 351         modify $ \s -> s { clientMarks = insertMark mark uriId $ clientMarks s }
 352         unless (mark `elem` tempMarks) . liftIO .
 353             handle printIOErr $ saveMark marksDir mark uriId
 354     setMark mark _ = printErr $ "Invalid mark name " ++ mark
 355
 356     promptInput = if ghost then promptLine else promptLineWithHistoryFile inputHistPath
 357         where inputHistPath = userDataDir </> "inputHistory"
 358
 359     handleCommandLine' :: Maybe PTarget -> Maybe (String, [CommandArg]) -> ClientM ()
 360     handleCommandLine' mt mcas = void . runMaybeT $ do
 361         ts <- case mt of
 362             Nothing -> return []
 363             Just pt -> either ((>> mzero) . printErr)
 364                 (\ts -> mapM_ addTargetId ts >> return ts) $
 365                 resolveTarget cState pt
 366         case mcas of
 367             Nothing -> lift $ handleBareTargets ts
 368             Just (s,as) -> do
 369                 c' <- maybe (printErr (unknownCommand s) >> mzero)
 370                     return $ normaliseCommand s
 371                 lift $ handleCommand ts (c',as)
 372         where
 373         unknownCommand s = "Unknown command \"" <> s <> "\". Type \"help\" for help."
 374         addTargetId :: Target -> MaybeT ClientM ()
 375         addTargetId (TargetIdUri idName uri) =
 376             liftIO (loadIdentity idsPath idName) >>= (\case
 377                 (Nothing, _) -> printErr ("Bad URI: " ++ show uri) >> mzero
 378                 (_, Nothing) -> printErr ("Unknown identity: " ++ showIdentityName ansi idName) >> mzero
 379                 (Just req, Just ident) -> lift $ addIdentity req ident) . (requestOfUri uri,)
 380         addTargetId _ = return ()
 381
 382     doPage :: [T.Text] -> ClientM ()
 383     doPage ls
 384         | interactive = do
 385             (height,width) <- liftIO getTermSize
 386             let pageWidth = min maxWrapWidth (width - 4)
 387                 perPage = height - min 3 (height `div` 4)
 388                 doCmd str = get >>= \s -> doSubCommand s True str
 389             printLinesPaged pageWidth width perPage doCmd ls
 390         | otherwise = liftIO $ mapM_ T.putStrLn ls
 391
 392     handleBareTargets :: [Target] -> ClientM ()
 393     handleBareTargets [] = return ()
 394     handleBareTargets (_:_:_) =
 395         printErr "Can only go to one place at a time. Try \"show\" or \"page\"?"
 396     handleBareTargets [TargetHistory item] = goHistory item
 397     handleBareTargets [TargetFrom origin uri] = goUri False (Just origin) uri
 398     handleBareTargets [t] = goUri False Nothing $ targetUri t
 399
 400
 401     handleCommand :: [Target] -> (String, [CommandArg]) -> ClientM ()
 402     handleCommand _ (c,_) | restrictedMode && notElem c (commands True) =
 403         printErr "Command disabled in restricted mode"
 404     handleCommand [] ("help", args) = case args of
 405         []                 -> doPage . map (T.pack . expand) $ helpText
 406         CommandArg s _ : _ -> doPage . map (T.pack . expand) $ helpOn s
 407     handleCommand [] ("commands",_) = doPage $ T.pack . expand <$> commandHelpText
 408         where
 409         commandHelpText = ["Aliases:"] ++ (showAlias <$> aliases) ++
 410             ["","Commands:"] ++ (('{' :) . (<> "}") <$> commands False)
 411         showAlias (a, Alias s _) = "{" <> a <> "}: " <> s
 412
 413     handleCommand [] ("mark", []) =
 414         let ms = M.toAscList marks
 415             markLine (m, Just uriId) = let m' = showMinPrefix ansi (fst <$> ms) m
 416                 in T.pack $ "'" <> m' <>
 417                     replicate (max 1 $ 16 - visibleLength (T.pack m')) ' ' <>
 418                     showUriWithId uriId
 419             markLine (m, Nothing) = T.pack $ "'" <> m <> " [Failed to read mark]"
 420         in doPage $ markLine <$> ms
 421     handleCommand [] ("inventory",_) = do
 422         ais <- gets clientActiveIdentities
 423         let showNumberedUri :: Bool -> T.Text -> (Int,URI) -> T.Text
 424             showNumberedUri iter s (n,uri) = s <>
 425                 (if iter && n == 1 then " "
 426                     else if iter && n == 2 then T.takeEnd 1 s
 427                     else T.pack (show n)) <>
 428                 " " <> showUriFull ansi ais Nothing uri
 429             showIteratedItem s (n,item) = showNumberedUri True s (n, historyUri item)
 430             showNumberedItem s (n,item) = showNumberedUri False s (n, historyUri item)
 431             showIteratedQueueItem s (n, QueueURI _ uri) =
 432                 showNumberedUri True s (n, uri)
 433             showIteratedQueueItem s (n, QueueHistory item) =
 434                 showNumberedUri True s (n, historyUri item) <> " {fetched}"
 435             showJumpBack :: [T.Text]
 436             showJumpBack = maybeToList $ ("'' " <>) . showUriFull ansi ais Nothing . historyUri <$> jumpBack
 437         doPage . intercalate [""] . filter (not . null) $
 438             showJumpBack :
 439             [ showIteratedQueueItem (T.pack $ qname <> "~") <$> zip [1..] queue
 440                 | (qname, queue) <- M.toList queues ]
 441             ++ [ showNumberedItem "'" <$> M.toAscList sessionMarks
 442             , (showIteratedItem "<" <$> zip [1..] (maybe [] (initSafe . historyAncestors) curr))
 443             ++ (("@  " <>) . showUriFull ansi ais Nothing . historyUri <$>
 444                 maybeToList (curr >>= lastMay . historyAncestors))
 445             , showIteratedItem ">" <$> zip [1..] (maybe [] historyDescendants curr)
 446             ]
 447     handleCommand [] ("log",_) =
 448         let showLog (n,t) = "$" <> T.pack (show n) <> " " <> colour Yellow t
 449         in doPage $ showLog <$> zip [(1::Int)..] (BStack.toList cLog)
 450     handleCommand [] ("alias", CommandArg a _ : CommandArg _ str : _) = void . runMaybeT $ do
 451         c <- either ((>>mzero) . printErr) return $ parseCommand a
 452         when (c /= a) $ printErr ("Bad alias: " <> a) >> mzero
 453         cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
 454         modify $ \s ->
 455                 s { clientAliases = insertAlias a (Alias str cl) . deleteAlias a $ clientAliases s }
 456     handleCommand [] ("alias", [CommandArg a _]) =
 457         modify $ \s -> s { clientAliases = deleteAlias a $ clientAliases s }
 458     handleCommand [] ("set", []) = liftIO $ do
 459         let (c,args) = defaultAction
 460         putStrLn $ expand "{default_action}: " <> c <>
 461             maybe "" ((" "<>) . commandArgLiteralTail) (headMay args)
 462         putStrLn $ expand "{proxies}:"
 463         printMap showHost $ M.toAscList proxies
 464         putStrLn $ expand "{geminators}:"
 465         printMap id $ second snd <$> geminators
 466         putStrLn $ expand "{render_filter}: " <> fromMaybe "" renderFilter
 467         putStrLn $ expand "{pre_display}: " <> showPreOpt preOpt
 468         putStrLn $ expand "{link_desc_first}: " <> show linkDescFirst
 469         putStrLn $ expand "{log_length}: " <> show maxLogLen
 470         putStrLn $ expand "{max_wrap_width}: " <> show maxWrapWidth
 471         putStrLn $ expand "{no_confirm}: " <> show noConfirm
 472         putStrLn $ expand "{verbose_connection}: " <> show verboseConnection
 473         where
 474             printMap :: (a -> String) -> [(String,a)] -> IO ()
 475             printMap f as = mapM_ putStrLn $
 476                 (\(k,e) -> "  " <> k <> " " <> f e) <$> as
 477     handleCommand [] ("set", CommandArg opt _ : val)
 478         | opt `isPrefixOf` "default_action" = case val of
 479             (CommandArg cmd _ : args) -> case actionOfCommand (cmd,args) of
 480                 Just _ -> modifyCConf $ \c -> c { clientConfDefaultAction = (cmd,args) }
 481                 Nothing -> printErr "Invalid action"
 482             _ -> printErr "Require value for option."
 483         | opt `isPrefixOf` "proxies" || opt `isPrefixOf` "proxy" = case val of
 484             (CommandArg scheme _ : val') ->
 485                 let f = maybe (M.delete scheme) (M.insert scheme) $
 486                         parseHost . commandArgLiteralTail =<< headMay val'
 487                 in modifyCConf $ \c -> c { clientConfProxies = f $ clientConfProxies c }
 488                     -- if only I'd allowed myself to use lenses, eh?
 489             [] -> printErr "Require mimetype to set geminator for."
 490         | opt `isPrefixOf` "geminators" = case val of
 491             (CommandArg patt _ : val') ->
 492                 let f = maybe (filter $ (/= patt) . fst)
 493                         (\v -> (++ [(patt, (mkRegexWithOpts patt True True,
 494                             commandArgLiteralTail v))])) $
 495                         headMay val'
 496                 in modifyCConf $ \c -> c { clientConfGeminators = f $ clientConfGeminators c }
 497             [] -> printErr "Require mimetype to set geminator for."
 498         | opt `isPrefixOf` "render_filter" =
 499             modifyCConf $ \c -> c { clientConfRenderFilter =
 500                 commandArgLiteralTail <$> headMay val }
 501         | opt `isPrefixOf` "pre_display" = case val of
 502             [CommandArg s _] | map toLower s `isPrefixOf` "both" ->
 503                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptBoth }
 504             [CommandArg s _] | map toLower s `isPrefixOf` "pre" ->
 505                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptPre }
 506             [CommandArg s _] | map toLower s `isPrefixOf` "alt" ->
 507                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptAlt }
 508             _ -> printErr "Require \"both\" or \"pre\" or \"alt\" for pre_display"
 509         | opt `isPrefixOf` "link_desc_first" = case val of
 510             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 511                 modifyCConf $ \c -> c { clientConfLinkDescFirst = True }
 512             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 513                 modifyCConf $ \c -> c { clientConfLinkDescFirst = False }
 514             _ -> printErr "Require \"true\" or \"false\" as value for link_desc_first"
 515         | opt `isPrefixOf` "log_length" = case val of
 516             [CommandArg s _] | Just n <- readMay s, n >= 0 -> do
 517                 modifyCConf $ \c -> c { clientConfMaxLogLen = n }
 518                 modify $ \st -> st { clientLog = BStack.truncate n $ clientLog st }
 519             _ -> printErr "Require non-negative integer value for log_length"
 520         | opt `isPrefixOf` "max_wrap_width" = case val of
 521             [CommandArg s _] | Just n <- readMay s, n > 0 ->
 522                 modifyCConf $ \c -> c { clientConfMaxWrapWidth = n }
 523             _ -> printErr "Require positive integer value for max_wrap_width"
 524         | opt `isPrefixOf` "no_confirm" = case val of
 525             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 526                 modifyCConf $ \c -> c { clientConfNoConfirm = True }
 527             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 528                 modifyCConf $ \c -> c { clientConfNoConfirm = False }
 529             _ -> printErr "Require \"true\" or \"false\" as value for no_confirm"
 530         | opt `isPrefixOf` "verbose_connection" = case val of
 531             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 532                 modifyCConf $ \c -> c { clientConfVerboseConnection = True }
 533             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 534                 modifyCConf $ \c -> c { clientConfVerboseConnection = False }
 535             _ -> printErr "Require \"true\" or \"false\" as value for verbose_connection"
 536         | otherwise = printErr $ "No such option \"" <> opt <> "\"."
 537     handleCommand [] cargs =
 538         case curr of
 539             Just item -> handleCommand [TargetHistory item] cargs
 540             Nothing -> printErr "No current location. Enter an URI, or type \"help\"."
 541
 542     handleCommand ts ("add", args) = case parseQueueSpec $ commandArgArg <$> args of
 543         Nothing -> printErr "Bad arguments to 'add'."
 544         Just qs -> modifyQueues . enqueue qs $ targetQueueItem <$> ts
 545
 546     handleCommand ts ("fetch", args) = case parseQueueSpec $ commandArgArg <$> args of
 547         Nothing -> printErr "Bad arguments to 'fetch."
 548         Just qs -> do
 549             -- XXX: we have to use an IORef to store the items, since
 550             -- CommandAction doesn't allow a return value.
 551             lRef <- liftIO $ newIORef []
 552             let add item = liftIO $ slurpItem item >> modifyIORef lRef (item:)
 553             forM_ ts $ \t -> case t of
 554                 TargetHistory item -> add item
 555                 _ -> modifyQueues (unqueue uri) >> doRequestUri uri add
 556                     where uri = targetUri t
 557             l <- liftIO $ reverse <$> readIORef lRef
 558             modifyQueues . enqueue qs $ QueueHistory <$> l
 559
 560     handleCommand ts cargs =
 561         mapM_ handleTargetCommand ts
 562         where
 563         handleTargetCommand (TargetHistory item) | Just action <- actionOfCommand cargs =
 564             action item
 565         handleTargetCommand t | Just action <- actionOfCommand cargs =
 566             let uri = targetUri t
 567             in modifyQueues (unqueue uri) >> doRequestUri uri action
 568         handleTargetCommand (TargetHistory item) | ("repeat",_) <- cargs =
 569             goUri True (recreateOrigin <$> historyParent item) $ historyUri item
 570         handleTargetCommand (TargetHistory item) | ("repl",_) <- cargs =
 571             repl (recreateOrigin <$> historyParent item) $ historyUri item
 572         handleTargetCommand t | ("query", CommandArg _ str : _) <- cargs = do
 573             let origin = case t of
 574                     TargetHistory item -> Just $ HistoryOrigin item Nothing
 575                     TargetFrom o _     -> Just o
 576                     _                  -> Nothing
 577             str' <- preprocessQuery str
 578             goUri True origin . setQuery ('?':str') $ targetUri t
 579         handleTargetCommand t =
 580             handleUriCommand (targetUri t) cargs
 581
 582         recreateOrigin :: HistoryItem -> HistoryOrigin
 583         recreateOrigin parent = HistoryOrigin parent $ childLink =<< historyChild parent
 584
 585         handleUriCommand uri ("delete",[]) =
 586             modifyQueues $ unqueueFrom "" uri
 587         handleUriCommand uri ("delete",CommandArg qname _ : _) =
 588             modifyQueues $ unqueueFrom qname uri
 589         handleUriCommand uri ("repeat",_) = goUri True Nothing uri
 590         handleUriCommand uri ("uri",_) = showUri uri
 591         handleUriCommand uri ("mark", CommandArg mark _ : _)
 592             | Just _ <- readMay mark :: Maybe Int = error "Bad mark for uri"
 593             | otherwise = do
 594             ais <- gets clientActiveIdentities
 595             let mIdName = case findIdentity ais =<< requestOfUri uri of
 596                     Just ident | not $ isTemporary ident -> Just $ identityName ident
 597                     _ -> Nothing
 598             setMark mark $ URIWithIdName uri mIdName
 599         handleUriCommand uri ("identify", args) = case requestOfUri uri of
 600             Nothing -> printErr "Bad URI"
 601             Just req -> gets ((`findIdentityRoot` req) . clientActiveIdentities) >>= \case
 602                 Just (root,(ident,_)) | null args -> endIdentityPrompted root ident
 603                 _ -> void . runMaybeT $ do
 604                     ident <- MaybeT . liftIO $ case args of
 605                         CommandArg idName _ : args' ->
 606                             let tp = case args' of
 607                                     CommandArg ('e':'d':_) _ : _ -> KeyEd25519
 608                                     _                            -> KeyRSA
 609                             in getIdentity interactive ansi idsPath tp idName
 610                         [] -> if interactive
 611                             then getIdentityRequesting ansi idsPath
 612                             else getIdentity interactive ansi idsPath KeyRSA ""
 613                     lift $ addIdentity req ident
 614         handleUriCommand uri ("browse", args) = do
 615             ais <- gets clientActiveIdentities
 616             let envir = maybe [] (identityEnvironment idsPath) .
 617                     idAtUri ais . setSchemeDefault $ uri
 618             void . liftIO . runMaybeT $ do
 619                 cmd <- case args of
 620                     [] -> maybe notSet
 621                         (\s -> if null s then notSet else return $ parseBrowser s) =<<
 622                             lift (lookupEnv "BROWSER")
 623                         where
 624                         notSet = printErr "Please set $BROWSER or give a command to run" >> mzero
 625                         -- |based on specification for $BROWSER in 'man 1 man'
 626                         parseBrowser :: String -> String
 627                         parseBrowser = subPercentOrAppend (show uri) . takeWhile (/=':')
 628                     (CommandArg _ c : _) -> return $ subPercentOrAppend (show uri) c
 629                 lift $ confirm (confirmShell "Run" cmd) >>? doRestricted $ void (runShellCmd cmd envir)
 630         handleUriCommand uri ("repl",_) = repl Nothing uri
 631         handleUriCommand uri ("log",_) = addToLog uri >> modifyQueues (unqueue uri)
 632
 633         handleUriCommand _ (c,_) = printErr $ "Bad arguments to command " <> c
 634
 635         repl :: Maybe HistoryOrigin -> URI -> ClientM ()
 636         repl origin uri = repl' where
 637             repl' = liftIO (join <$> promptInput ">> ") >>= \case
 638                 Nothing -> return ()
 639                 Just query -> do
 640                     query' <- preprocessQuery query
 641                     goUri True origin . setQuery ('?':query') $ uri
 642                     repl'
 643
 644     slurpItem :: HistoryItem -> IO ()
 645     slurpItem item = slurpNoisily (historyRequestTime item) . mimedBody $ historyMimedData item
 646
 647     actionOnRendered :: Bool -> ([T.Text] -> ClientM ()) -> CommandAction
 648     actionOnRendered ansi' m item = do
 649         ais <- gets clientActiveIdentities
 650         liftIO (renderMimed ansi' (historyUri item) ais (historyGeminatedMimedData item)) >>=
 651             either printErr m
 652
 653     actionOfCommand :: (String, [CommandArg]) -> Maybe CommandAction
 654     actionOfCommand (c,_) | restrictedMode && notElem c (commands True) = Nothing
 655     actionOfCommand ("show",_) = Just . actionOnRendered ansi $ liftIO . mapM_ T.putStrLn
 656     actionOfCommand ("page",_) = Just $ actionOnRendered ansi doPage
 657     actionOfCommand ("links",_) = Just $ \item -> do
 658         ais <- gets clientActiveIdentities
 659         let cl = childLink =<< historyChild item
 660             linkLine n (Link uri desc) =
 661                 applyIf (cl == Just (n-1)) (bold "* " <>) $
 662                 T.pack ('[' : show n ++ "] ")
 663                     <> showUriRefFull ansi ais (historyUri item) uri
 664                     <> if T.null desc then "" else " " <>
 665                         applyIf ansi (withColourStr Cyan) desc
 666         doPage . zipWith linkLine [1..] . historyLinks $ item
 667
 668     actionOfCommand ("mark", CommandArg mark _ : _) |
 669         Just n <- readMay mark :: Maybe Int = Just $ \item -> do
 670             liftIO $ slurpItem item
 671             modify $ \s -> s { clientSessionMarks = M.insert n item $ clientSessionMarks s }
 672     actionOfCommand ("mime",_) = Just $ liftIO . putStrLn . showMimeType . historyMimedData
 673     actionOfCommand ("save", []) = actionOfCommand ("save", [CommandArg "" savesDir])
 674     actionOfCommand ("save", CommandArg _ path : _) = Just $ \item -> liftIO . doRestricted . RestrictedIO $ do
 675         createDirectoryIfMissing True savesDir
 676         homePath <- getHomeDirectory
 677         let path'
 678                 | take 2 path == "~/" = homePath </> drop 2 path
 679                 | take 1 path == "/" || take 2 path == "./" || take 3 path == "../" = path
 680                 | otherwise = savesDir </> path
 681             body = mimedBody $ historyMimedData item
 682             uri = historyUri item
 683             name = fromMaybe (fromMaybe "" $ uriRegName uri) . lastMay .
 684                 filter (not . null) $ pathSegments uri
 685         handle printIOErr . void . runMaybeT $ do
 686             lift $ mkdirhierto path'
 687             isDir <- lift $ doesDirectoryExist path'
 688             let fullpath = if isDir then path' </> name else path'
 689             lift (doesDirectoryExist fullpath) >>? do
 690                 lift . printErr $ "Path " ++ show fullpath ++ " exists and is directory"
 691                 mzero
 692             lift (doesFileExist fullpath) >>?
 693                 guard =<< lift (promptYN False $ "Overwrite " ++ show fullpath ++ "?")
 694             lift $ do
 695                 putStrLn $ "Saving to " ++ fullpath
 696                 t0 <- timeCurrentP
 697                 BL.writeFile fullpath =<< interleaveProgress t0 body
 698
 699     actionOfCommand ("!", CommandArg _ cmd : _) = Just $ \item -> do
 700         env <- historyEnv item
 701         liftIO . handle printIOErr . doRestricted .
 702             shellOnData noConfirm cmd userDataDir env . mimedBody $ historyMimedData item
 703
 704     actionOfCommand ("view",_) = Just $ \item ->
 705         let mimed = historyMimedData item
 706             mimetype = showMimeType mimed
 707             body = mimedBody mimed
 708         in liftIO . handle printIOErr . doRestricted $ runMailcap noConfirm "view" userDataDir mimetype body
 709     actionOfCommand ("|", CommandArg _ cmd : _) = Just $ \item -> do
 710         env <- historyEnv item
 711         liftIO . handle printIOErr . doRestricted $
 712             pipeToShellLazily cmd env . mimedBody $ historyMimedData item
 713     actionOfCommand ("||", args) = Just $ pipeRendered ansi args
 714     actionOfCommand ("||-", args) = Just $ pipeRendered False args
 715     actionOfCommand ("cat",_) = Just $ liftIO . BL.putStr . mimedBody . historyMimedData
 716     actionOfCommand ("at", CommandArg _ str : _) = Just $ \item ->
 717         doSubCommand (cState { clientCurrent = Just item }) blockGo str
 718     actionOfCommand _ = Nothing
 719
 720     pipeRendered :: Bool -> [CommandArg] -> CommandAction
 721     pipeRendered ansi' args item = (\action -> actionOnRendered ansi' action item) $ \ls -> do
 722         env <- historyEnv item
 723         liftIO . void . runMaybeT $ do
 724             cmd <- case args of
 725                 [] -> maybe notSet
 726                     (\s -> if null s then notSet else return s) =<<
 727                     liftIO (lookupEnv "PAGER")
 728                     where
 729                     notSet = printErr "Please set $PAGER or give a command to run" >> mzero
 730                 (CommandArg _ cmd : _) -> return cmd
 731             lift . doRestricted . pipeToShellLazily cmd env . T.encodeUtf8 $ T.unlines ls
 732
 733     doSubCommand :: ClientState -> Bool -> String -> ClientM ()
 734     doSubCommand s block str = void . runMaybeT $ do
 735         cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
 736         lift $ handleCommandLine cOpts s block cl
 737
 738     setCurr :: HistoryItem -> ClientM ()
 739     setCurr i =
 740         let isJump = isNothing $ curr >>= pathItemByUri i . historyUri
 741         in do
 742             when isJump $ modify $ \s -> s { clientJumpBack = curr }
 743             modify $ \s -> s { clientCurrent = Just i }
 744
 745     doDefault :: HistoryItem -> ClientM ()
 746     doDefault item =
 747         maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction
 748
 749     goHistory :: HistoryItem -> ClientM ()
 750     goHistory _ | blockGo = printErr "Can't go anywhere now."
 751     goHistory item = do
 752         modifyQueues $ unqueue uri
 753         showUri uri
 754         setCurr item
 755         doDefault item
 756         where uri = historyUri item
 757
 758     goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM ()
 759     goUri _ _ _ | blockGo = printErr "Can't go anywhere now."
 760     goUri forceRequest origin uri = do
 761         modifyQueues $ unqueue uri
 762         activeId <- gets $ isJust . (`idAtUri` uri) . clientActiveIdentities
 763         case curr >>= flip pathItemByUri uri of
 764             Just i' | not (activeId || forceRequest) -> goHistory i'
 765             _ -> doRequestUri uri $ \item -> do
 766                 let updateParent i =
 767                         -- Lazily recursively update the links in the doubly linked list
 768                         let i' = i { historyParent = updateParent . updateChild i' <$> historyParent i }
 769                         in i'
 770                     updateChild i' i = i { historyChild = setChild <$> historyChild i }
 771                         where setChild c = c { childItem = i' }
 772                     glueOrigin (HistoryOrigin o l) = updateParent $ o { historyChild = Just $ HistoryChild item' l }
 773                     item' = item { historyParent = glueOrigin <$> origin }
 774                 setCurr item'
 775                 doDefault item
 776                 liftIO $ slurpItem item
 777
 778     doRequestUri :: URI -> CommandAction -> ClientM ()
 779     doRequestUri uri0 action = doRequestUri' 0 uri0
 780         where
 781         doRequestUri' redirs uri
 782             | Just req <- requestOfUri uri = addToLog uri >> doRequest redirs req
 783             | otherwise = printErr $ "Bad URI: " ++ displayUri uri ++ (
 784                     let scheme = uriScheme uri
 785                     in if scheme /= "gemini" && isNothing (M.lookup scheme proxies)
 786                     then " : No proxy set for non-gemini scheme " ++ scheme ++ "; use \"browse\"?"
 787                     else "")
 788
 789         doRequest :: Int -> Request -> ClientM ()
 790         doRequest redirs _ | redirs > 5 =
 791             printErr "Too many redirections!"
 792         doRequest redirs req@(NetworkRequest _ uri) = do
 793             (mId, ais) <- liftIO . useActiveIdentity noConfirm ansi req =<< gets clientActiveIdentities
 794             modify $ \s -> s { clientActiveIdentities = ais }
 795             printInfo $ ">>> " ++ showUriFull ansi ais Nothing uri
 796             let respBuffSize = 2 ^ (15::Int) -- 32KB max cache for response stream
 797             liftIO (makeRequest requestContext mId respBuffSize verboseConnection req)
 798                 `bracket` either (\_ -> return ()) (liftIO . snd) $
 799                 either
 800                     (printErr . displayException)
 801                     (handleResponse . fst)
 802             where
 803             handleResponse :: Response -> ClientM ()
 804             handleResponse (Input isPass prompt) = do
 805                 let defaultPrompt = "[" ++ (if isPass then "PASSWORD" else "INPUT") ++ "]"
 806                 (liftIO . (join <$>) . promptInput $
 807                         (if null prompt then defaultPrompt else prompt) ++ " > ") >>= \case
 808                     Nothing -> return ()
 809                     Just query -> do
 810                         query' <- preprocessQuery query
 811                         doRequestUri' redirs . setQuery ('?':query') $ uri
 812
 813             handleResponse (Success mimedData) = doAction req mimedData
 814
 815             handleResponse (Redirect isPerm to) = do
 816                 ais <- gets clientActiveIdentities
 817                 let uri' = to `relativeTo` uri
 818                     crossSite = uriRegName uri' /= uriRegName uri
 819                     crossScheme = uriScheme uri' /= uriScheme uri
 820                     crossScope = case idAtUri ais <$> [uri,uri'] of
 821                             [fromId,toId] -> isJust toId && fromId /= toId
 822                             _             -> False
 823                     warningStr = colour BoldRed
 824                 proceed <- (isJust <$>) . lift . runMaybeT $ do
 825                     when crossSite $ guard <=< (liftIO . promptYN False) $
 826                         warningStr "Follow cross-site redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
 827                     when crossScheme $ guard <=< (liftIO . promptYN False) $
 828                         warningStr "Follow cross-protocol redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
 829                     when crossScope $ guard <=< (liftIO . promptYN False) $
 830                         warningStr "Follow redirect with identity " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
 831                 when proceed $ do
 832                     when (isPerm && not ghost) . mapM_ (updateMark uri') . marksWithUri uri =<< gets clientMarks
 833                     doRequestUri' (redirs + 1) uri'
 834                 where updateMark uri' (mark,uriId) = do
 835                         conf <- confirm . liftIO . promptYN True $ "Update mark '" <> mark <> " to " <> show uri' <> " ?"
 836                         when conf . setMark mark $ uriId { uriIdUri = uri' }
 837             handleResponse (Failure code info) | 60 <= code && code <= 69 = void . runMaybeT $ do
 838                 identity <- do
 839                         liftIO . putStrLn $ (case code of
 840                             60 -> "Server requests identification"
 841                             _ -> "Server rejects provided identification certificate" ++
 842                                 (if code == 61 then " as unauthorised" else if code == 62 then " as invalid" else ""))
 843                             ++ if null info then "" else ": " ++ info
 844                         guard interactive
 845                         MaybeT . liftIO $ getIdentityRequesting ansi idsPath
 846                 lift $ do
 847                     addIdentity req identity
 848                     doRequest redirs req
 849
 850             handleResponse (Failure 44 info) = do
 851                 printInfo $ "Server requests slowdown: " ++ info
 852                 liftIO . threadDelay $ 1000 * 2^redirs
 853                 doRequest (redirs+1) req
 854             handleResponse (Failure code info) =
 855                 printErr $ "Server returns failure: " ++ show code ++ " " ++ info
 856             handleResponse (MalformedResponse malformation) =
 857                 printErr $ "Malformed response from server: " ++ show malformation
 858
 859         doRequest redirs (LocalFileRequest path) | redirs > 0 = printErr "Ignoring redirect to local file."
 860             | otherwise = void . runMaybeT $ do
 861                 (path', mimedData) <- MaybeT . liftIO . doRestrictedAlt . RestrictedIO . warnIOErrAlt $ do
 862                     let detectExtension = case takeExtension path of
 863                             -- |certain crucial filetypes we can't rely on magic to detect:
 864                             s | s `elem` [".gmi", ".gem", ".gemini"] -> Just "text/gemini"
 865                             ".md" -> Just "text/markdown"
 866                             ".html" -> Just "text/html"
 867                             _ -> Nothing
 868 #ifdef MAGIC
 869                         detectPlain "text/plain" = fromMaybe "text/plain" detectExtension
 870                         detectPlain s = s
 871                     magic <- Magic.magicOpen [Magic.MagicMimeType]
 872                     Magic.magicLoadDefault magic
 873                     s <- detectPlain <$> Magic.magicFile magic path
 874 #else
 875                     let s = if "/" `isSuffixOf` path then "inode/directory"
 876                             else fromMaybe "application/octet-stream" detectExtension
 877 #endif
 878                     case MIME.parseMIMEType $ TS.pack s of
 879                         Nothing -> printErr ("Failed to parse mimetype string: " <> s) >> return Nothing
 880                         _ | s == "inode/directory" -> Just . (slashedPath,) . MimedData gemTextMimeType .
 881                             T.encodeUtf8 . T.unlines .
 882                             ((("=> " <>) . T.pack . escapePathString) <$>) . sort <$>
 883                                 getDirectoryContents path
 884                             where slashedPath | "/" `isSuffixOf` path = path
 885                                     | otherwise = path <> "/"
 886                         Just mimetype -> Just . (path,) . MimedData mimetype <$> BL.readFile path
 887                 lift $ doAction (LocalFileRequest path') mimedData
 888
 889         doAction req mimedData = do
 890             t0 <- liftIO timeCurrentP
 891             geminated <- geminate mimedData
 892             action $ HistoryItem req t0 mimedData geminated Nothing Nothing
 893             where
 894             -- |returns MimedData with lazy IO
 895             geminate :: MimedData -> ClientM MimedData
 896             geminate mimed =
 897                 let geminator = lookupGeminator $ showMimeType mimed
 898                 in liftIO . unsafeInterleaveIO $ applyGeminator geminator
 899                 where
 900                 lookupGeminator mimetype =
 901                     listToMaybe [ gem | (_, (regex, gem)) <- geminators
 902                         , isJust $ matchRegex regex mimetype ]
 903                 applyGeminator Nothing = return mimed
 904                 applyGeminator (Just cmd) =
 905                     printInfo ("| " <> cmd) >>
 906                     MimedData gemTextMimeType <$>
 907                         doRestrictedFilter (filterShell cmd [("URI", show $ requestUri req)]) (mimedBody mimed)
 908
 909         gemTextMimeType :: MIME.Type
 910         gemTextMimeType = MIME.Type (MIME.Text "gemini") []
 911
 912
 913     addIdentity :: Request -> Identity -> ClientM ()
 914     addIdentity req identity = do
 915         ais <- gets clientActiveIdentities >>= liftIO . insertIdentity req identity
 916         modify $ \s -> s {clientActiveIdentities = ais}
 917     endIdentityPrompted :: Request -> Identity -> ClientM ()
 918     endIdentityPrompted root ident = do
 919         conf <- confirm $ liftIO . promptYN False $ "Stop using " ++
 920             (if isTemporary ident then "temporary anonymous identity" else showIdentity ansi ident) ++
 921             " at " ++ displayUri (requestUri root) ++ "?"
 922         when conf . modify $ \s ->
 923                 s { clientActiveIdentities = deleteIdentity root $ clientActiveIdentities s }
 924
 925     renderMimed :: Bool -> URI -> ActiveIdentities -> MimedData -> IO (Either String [T.Text])
 926     renderMimed ansi' uri ais (MimedData mime body) = case MIME.mimeType mime of
 927         MIME.Text textType -> do
 928             let extractCharsetParam (MIME.MIMEParam "charset" v) = Just v
 929                 extractCharsetParam _                            = Nothing
 930                 charset = TS.unpack . fromMaybe "utf-8" . msum . map extractCharsetParam $ MIME.mimeParams mime
 931                 isUtf8 = map toLower charset `elem` ["utf-8", "utf8"]
 932 #ifdef ICONV
 933                 reencoder = if isUtf8 then id else
 934                     convert charset "UTF-8"
 935 #else
 936                 reencoder = id
 937             unless isUtf8 . printErr $
 938                 "Warning: Treating unsupported charset " ++ show charset ++ " as utf-8"
 939 #endif
 940             (_,width) <- getTermSize
 941             let pageWidth = if interactive
 942                 then min maxWrapWidth (width - 4)
 943                 else maxWrapWidth
 944             let bodyText = T.decodeUtf8With T.lenientDecode $ reencoder body
 945                 applyFilter :: [T.Text] -> IO [T.Text]
 946                 applyFilter = case renderFilter of
 947                     Nothing -> return
 948                     Just cmd -> (T.lines . T.decodeUtf8With T.lenientDecode <$>) .
 949                         doRestrictedFilter (filterShell cmd []) . BL.concat . (appendNewline . T.encodeUtf8 <$>)
 950                         where appendNewline = (`BL.snoc` 10)
 951             (Right <$>) . applyFilter $ case textType of
 952                     "gemini" ->
 953                         let opts = GemRenderOpts ansi' preOpt pageWidth linkDescFirst
 954                         in printGemDoc opts (showUriRefFull ansi' ais uri) $ parseGemini bodyText
 955                     "x-ansi" -> T.stripEnd . sanitiseForDisplay <$> T.lines bodyText
 956                     _ -> T.stripEnd . stripControlExceptTab <$> T.lines bodyText
 957         mimeType ->
 958             return . Left $ "No geminator for " ++ TS.unpack (MIME.showMIMEType mimeType) ++ " configured. Try \"save\", \"view\", \"!\", or \"|\"?"