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