LineClient.hs

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