diohsc.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020 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 Main 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, isUpper, toLower)
  25 import           Data.Hash                    (Hash, hash)
  26 import           Data.IORef                   (modifyIORef, newIORef, readIORef)
  27 import           Data.List                    (find, 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                   (Regex, matchRegex,
  38                                                mkRegexWithOpts)
  39 import           Time.System                  (timeCurrentP)
  40 import           Time.Types                   (ElapsedP)
  41
  42 import qualified Data.ByteString.Lazy         as BL
  43
  44 import qualified Codec.MIME.Parse             as MIME
  45 import qualified Codec.MIME.Type              as MIME
  46 import qualified Data.Map                     as M
  47 import qualified Data.Set                     as S
  48 import qualified Data.Text                    as TS
  49 import qualified Data.Text.Encoding.Error     as T
  50 import qualified Data.Text.Lazy               as T
  51 import qualified Data.Text.Lazy.Encoding      as T
  52 import qualified Data.Text.Lazy.IO            as T
  53 import qualified System.Console.Haskeline     as HL
  54 import qualified System.Console.Terminal.Size as Size
  55
  56 import           ANSIColour
  57 import           ActiveIdentities
  58 import           Alias
  59 import qualified BStack
  60 import           ClientCert                   (KeyType (..))
  61 import           Command
  62 import           CommandLine
  63 import           GeminiProtocol
  64 import           Identity
  65 import           Marks
  66 import           MetaString
  67 import           Mundanities
  68 import           Opts
  69 import           Pager
  70 import           Prompt                       hiding (promptYN)
  71 import qualified Prompt
  72 import           Request
  73 import           RunExternal                  hiding (runRestrictedIO)
  74 import qualified RunExternal
  75 import           Slurp
  76 import           TextGemini
  77 import           URI
  78 import           Util
  79 import           Version
  80
  81 #ifndef WINDOWS
  82 import           System.Posix.Files           (ownerModes, setFileMode)
  83 #endif
  84
  85 #ifdef ICONV
  86 import           Codec.Text.IConv             (convert)
  87 #endif
  88
  89 #ifdef MAGIC
  90 import qualified Magic
  91 #endif
  92
  93 -- |Immutable options set at startup
  94 data ClientOptions = ClientOptions
  95     { cOptUserDataDir    :: FilePath
  96     , cOptInteractive    :: Bool
  97     , cOptAnsi           :: Bool
  98     , cOptGhost          :: Bool
  99     , cOptRestrictedMode :: Bool
 100     , cOptRequestContext :: RequestContext
 101     , cOptLogH           :: Maybe Handle
 102     }
 103
 104 data HistoryChild = HistoryChild
 105     { childItem :: HistoryItem
 106     , childLink :: Maybe Int
 107     }
 108
 109 data HistoryOrigin = HistoryOrigin
 110     { originItem :: HistoryItem
 111     , originLink :: Maybe Int
 112     }
 113
 114 data HistoryItem = HistoryItem
 115     { historyRequest            :: Request
 116     , historyRequestTime        :: ElapsedP
 117     , historyMimedData          :: MimedData
 118     , historyGeminatedMimedData :: MimedData -- ^generated with lazy IO
 119     , historyParent             :: Maybe HistoryItem
 120     , historyChild              :: Maybe HistoryChild
 121     }
 122
 123 historyUri :: HistoryItem -> URI
 124 historyUri = requestUri . historyRequest
 125
 126 historyEnv :: HistoryItem -> [(String,String)]
 127 historyEnv item =
 128     [ ("URI", show $ historyUri item)
 129     , ("MIMETYPE", showMimeType $ historyMimedData item) ]
 130
 131 historyAncestors :: HistoryItem -> [HistoryItem]
 132 historyAncestors i = case historyParent i of
 133         Nothing -> []
 134         Just i' -> i' : historyAncestors i'
 135
 136 historyDescendants :: HistoryItem -> [HistoryItem]
 137 historyDescendants i = case historyChild i of
 138         Nothing                  -> []
 139         Just (HistoryChild i' _) -> i' : historyDescendants i'
 140
 141 pathItemByUri :: HistoryItem -> URI -> Maybe HistoryItem
 142 pathItemByUri i uri = find ((uri ==) . historyUri) $
 143     historyAncestors i ++ [i] ++ historyDescendants i
 144
 145 data ClientConfig = ClientConfig
 146     { clientConfDefaultAction     :: (String, [CommandArg])
 147     , clientConfProxies           :: M.Map String Host
 148     , clientConfGeminators        :: [(String,(Regex,String))]
 149     , clientConfRenderFilter      :: Maybe String
 150     , clientConfPreOpt            :: PreOpt
 151     , clientConfLinkDescFirst     :: Bool
 152     , clientConfMaxLogLen         :: Int
 153     , clientConfMaxWrapWidth      :: Int
 154     , clientConfNoConfirm         :: Bool
 155     , clientConfVerboseConnection :: Bool
 156     }
 157
 158 defaultClientConfig :: ClientConfig
 159 defaultClientConfig = ClientConfig ("page", []) M.empty [] Nothing PreOptPre False 1000 80 False False
 160
 161 data QueueItem
 162     = QueueURI (Maybe HistoryOrigin) URI
 163     | QueueHistory HistoryItem
 164
 165 queueUri :: QueueItem -> URI
 166 queueUri (QueueURI _ uri)    = uri
 167 queueUri (QueueHistory item) = historyUri item
 168
 169 data ClientState = ClientState
 170     { clientCurrent          :: Maybe HistoryItem
 171     , clientJumpBack         :: Maybe HistoryItem
 172     , clientLog              :: BStack.BStack T.Text
 173     , clientVisited          :: S.Set Hash
 174     , clientQueues           :: M.Map String [QueueItem]
 175     , clientActiveIdentities :: ActiveIdentities
 176     , clientMarks            :: Marks
 177     , clientSessionMarks     :: M.Map Int HistoryItem
 178     , clientAliases          :: Aliases
 179     , clientConfig           :: ClientConfig
 180     }
 181
 182 type ClientM = StateT ClientState IO
 183
 184 type CommandAction = HistoryItem -> ClientM ()
 185
 186 emptyClientState :: ClientState
 187 emptyClientState = ClientState Nothing Nothing BStack.empty S.empty M.empty M.empty emptyMarks M.empty defaultAliases defaultClientConfig
 188
 189 enqueue :: String -> Maybe Int -> [QueueItem] -> ClientM ()
 190 enqueue _ _ [] = return ()
 191 enqueue qname after qs = modify $ \s -> s {clientQueues =
 192         M.alter (Just . insertInNubbedList after qs queueUri) qname $ clientQueues s}
 193
 194 insertInNubbedList :: Eq b => Maybe Int -> [a] -> (a -> b) -> Maybe [a] -> [a]
 195 insertInNubbedList mn as f mbs =
 196     let bs = fromMaybe [] mbs
 197         (bs',bs'') = maybe (bs,[]) (`splitAt` bs) mn
 198         del as' = filter $ (`notElem` (f <$> as')) . f
 199     in del as bs' ++ as ++ del as bs''
 200
 201 dropUriFromQueue :: String -> URI -> ClientM ()
 202 dropUriFromQueue qname uri = modify $ \s -> s { clientQueues =
 203         M.adjust (filter ((/= uri) . queueUri)) qname $ clientQueues s }
 204
 205 dropUriFromQueues :: URI -> ClientM ()
 206 dropUriFromQueues uri = do
 207     qnames <- gets $ M.keys . clientQueues
 208     forM_ qnames (`dropUriFromQueue` uri)
 209
 210 modifyCConf :: (ClientConfig -> ClientConfig) -> ClientM ()
 211 modifyCConf f = modify $ \s -> s { clientConfig = f $ clientConfig s }
 212
 213 main :: IO ()
 214 main = do
 215     argv <- getArgs
 216     (opts,args) <- parseArgs argv
 217     when (Help `elem` opts) $ putStr usage >> exitSuccess
 218     when (Version `elem` opts) $ putStrLn version >> exitSuccess
 219
 220     defUserDataDir <- getAppUserDataDirectory programName
 221     userDataDir <- canonicalizePath . fromMaybe defUserDataDir $ listToMaybe [ path | DataDir path <- opts ]
 222     let restrictedMode = Restricted `elem` opts
 223
 224     outTerm <- hIsTerminalDevice stdout
 225     let ansi = NoAnsi `notElem` opts && (outTerm || Ansi `elem` opts)
 226
 227     let argCommands (ScriptFile "-") = warnIOErrAlt $
 228             (T.unpack . T.strip <$>) . T.lines <$> T.getContents
 229         argCommands (ScriptFile f) = warnIOErrAlt $ (T.unpack <$>) <$> readFileLines f
 230         argCommands (OptCommand c) = return [c]
 231         argCommands _ = return []
 232     optCommands <- concat <$> mapM argCommands opts
 233     let repl = (null optCommands && Batch `notElem` opts) || Prompt `elem` opts
 234     let interactive = Batch `notElem` opts && (repl || Interactive `elem` opts)
 235
 236     let argToUri arg = doesPathExist arg >>= \case
 237             True -> Just . ("file://" <>) . escapePathString <$> makeAbsolute arg
 238             False | Just uri <- parseUriAsAbsolute . escapeIRI $ arg -> return $ Just $ show uri
 239             _ -> printErrOpt ansi ("No such URI / file: " <> arg) >> return Nothing
 240     argCommand <- join <$> mapM argToUri (listToMaybe args)
 241
 242     let initialCommands = optCommands ++ maybeToList argCommand
 243
 244     let ghost = Ghost `elem` opts
 245
 246     unless ghost $ do
 247         mkdirhier userDataDir
 248 #ifndef WINDOWS
 249         setFileMode userDataDir ownerModes -- chmod 700
 250 #endif
 251
 252     let cmdHistoryPath = userDataDir </> "commandHistory"
 253         marksPath = userDataDir </> "marks"
 254         logPath = userDataDir </> "log"
 255
 256     let displayInfo :: [String] -> IO ()
 257         displayInfo = mapM_ $ printInfoOpt ansi
 258         displayWarning = mapM_ $ printErrOpt ansi
 259         promptYN = Prompt.promptYN interactive
 260         callbacks = InteractionCallbacks displayInfo displayWarning waitKey promptYN
 261         socksProxy = maybe (const NoSocksProxy) Socks5Proxy
 262             (listToMaybe [ h | SocksHost h <- opts ])
 263             . fromMaybe "1080" $ listToMaybe [ p | SocksPort p <- opts ]
 264
 265     requestContext <- initRequestContext callbacks userDataDir ghost socksProxy
 266     (warnings, marks) <- loadMarks marksPath
 267     displayWarning warnings
 268     let hlSettings = (HL.defaultSettings::HL.Settings ClientM)
 269             { HL.complete = HL.noCompletion
 270             , HL.historyFile = if ghost then Nothing else Just cmdHistoryPath
 271             }
 272
 273     cLog <- BStack.fromList . reverse <$> readFileLines logPath
 274     let visited = S.fromList $ hash . T.unpack <$> BStack.toList cLog
 275
 276     let openLog :: IO (Maybe Handle)
 277         openLog = ignoreIOErrAlt $ Just <$> do
 278             h <- openFile logPath AppendMode
 279             hSetBuffering h LineBuffering
 280             return h
 281         closeLog :: Maybe Handle -> IO ()
 282         closeLog = maybe (return ()) hClose
 283
 284     (if ghost then ($ Nothing) else bracketOnError openLog closeLog) $ \logH ->
 285         let clientOptions = ClientOptions userDataDir interactive ansi ghost
 286                 restrictedMode requestContext logH
 287             initState = emptyClientState {clientMarks = marks
 288                 , clientLog = cLog, clientVisited = visited}
 289         in do
 290             endState <- (`execStateT` initState) . HL.runInputT hlSettings $
 291                 lineClient clientOptions initialCommands repl
 292             closeLog logH
 293             -- |reread file rather than just writing clientLog, in case another instance has also
 294             -- been appending to the log.
 295             unless ghost . warnIOErr $ truncateToEnd (clientConfMaxLogLen $ clientConfig endState) logPath
 296
 297 printErrOpt :: MonadIO m => Bool -> String -> m ()
 298 printErrOpt ansi s = liftIO . hPutStrLn stderr . applyIf ansi (withColourStr BoldRed) $ "! " <> s
 299
 300 printInfoOpt :: MonadIO m => Bool -> String -> m ()
 301 printInfoOpt ansi s = liftIO . hPutStrLn stderr $ applyIf ansi withBoldStr ". " <> s
 302
 303 getTermSize :: IO (Int,Int)
 304 getTermSize = do
 305     Size.Window height width <- fromMaybe (Size.Window (2^(30::Int)) 80) <$> Size.size
 306     return (height,width)
 307
 308 lineClient :: ClientOptions -> [String] -> Bool -> HL.InputT ClientM ()
 309 lineClient cOpts@ClientOptions{ cOptUserDataDir = userDataDir
 310         , cOptInteractive = interactive, cOptAnsi = ansi, cOptGhost = ghost} initialCommands repl = do
 311     (liftIO . readFileLines $ userDataDir </> "diohscrc") >>= mapM_ (handleLine' . T.unpack)
 312     lift addToQueuesFromFiles
 313     mapM_ handleLine' initialCommands
 314     when repl lineClient'
 315     unless ghost $ lift appendQueuesToFiles
 316     where
 317     handleLine' :: String -> HL.InputT ClientM Bool
 318     handleLine' line = lift get >>= \s -> handleLine cOpts s line
 319
 320     lineClient' :: HL.InputT ClientM ()
 321     lineClient' = do
 322         cmd <- lift getPrompt >>= promptLineInputT
 323         lift addToQueuesFromFiles
 324         quit <- case cmd of
 325             Nothing -> if interactive
 326                 then printErrOpt ansi "Use \"quit\" to quit" >> return False
 327                 else return True
 328             Just Nothing -> return True
 329             Just (Just line) -> handleLine' line
 330         unless quit lineClient'
 331
 332     addToQueuesFromFiles :: ClientM ()
 333     addToQueuesFromFiles | ghost = return ()
 334         | otherwise = do
 335             qfs <- ignoreIOErr $ liftIO findQueueFiles
 336             forM_ qfs $ \(qfile, qname) -> enqueue qname Nothing <=<
 337                 ignoreIOErr . liftIO $
 338                 catMaybes . (queueLine <$>) <$> readFileLines qfile <* removeFile qfile
 339             ignoreIOErr . liftIO $ removeDirectory queuesDir
 340         where
 341         findQueueFiles :: IO [(FilePath,String)]
 342         findQueueFiles = do
 343             qf <- (\e -> [(queueFile, "") | e]) <$> doesFileExist queueFile
 344             qfs <- ((\qn -> (queuesDir </> qn, qn)) <$>) <$> listDirectory queuesDir
 345             return $ qf <> qfs
 346         queueLine :: T.Text -> Maybe QueueItem
 347         queueLine s = QueueURI Nothing <$> (parseUriAsAbsolute . escapeIRI $ T.unpack s)
 348
 349     appendQueuesToFiles :: ClientM ()
 350     appendQueuesToFiles = do
 351         queues <- gets $ M.toList . clientQueues
 352         liftIO $ createDirectoryIfMissing True queuesDir
 353         liftIO $ forM_ queues appendQueue
 354         where
 355         appendQueue (_, []) = pure ()
 356         appendQueue (qname, queue) =
 357             let qfile = case qname of
 358                     "" -> queueFile
 359                     s  -> queuesDir </> s
 360             in warnIOErr $ BL.appendFile qfile .
 361                 T.encodeUtf8 . T.unlines $ T.pack . show . queueUri <$> queue
 362
 363     queueFile, queuesDir :: FilePath
 364     queueFile = userDataDir </> "queue"
 365     queuesDir = userDataDir </> "queues"
 366
 367     getPrompt :: ClientM String
 368     getPrompt = do
 369         queue <- gets $ M.findWithDefault [] "" . clientQueues
 370         curr <- gets clientCurrent
 371         proxies <- gets $ clientConfProxies . clientConfig
 372         ais <- gets clientActiveIdentities
 373         let queueStatus :: Maybe String
 374             queueStatus = guard (not $ null queue) >> return (show (length queue) ++ "~")
 375             colour = applyIf ansi . withColourStr
 376             bold = applyIf ansi withBoldStr
 377             uriStatus :: Int -> URI -> String
 378             uriStatus w uri =
 379                 let fullUriStr = stripGem $ show uri
 380                     stripGem s = fromMaybe s $ stripPrefix "gemini://" s
 381                     mIdName = (identityName <$>) $ findIdentity ais =<< requestOfProxiesAndUri proxies uri
 382                     idStr = flip (maybe "") mIdName $ \idName ->
 383                         let abbrId = length idName > 8 && length fullUriStr + 2 + length idName > w - 2
 384                         in "[" ++ (if abbrId then ".." ++ take 6 idName else idName) ++ "]"
 385                     abbrUri = length fullUriStr + length idStr > w - 2
 386                     uriFormat = colour BoldMagenta
 387                     uriStr = if abbrUri
 388                         then
 389                             let abbrUriChars = w - 4 - length idStr
 390                                 preChars = abbrUriChars `div` 2
 391                                 postChars = abbrUriChars - preChars
 392                             in uriFormat (take preChars fullUriStr) <>
 393                             ".." <>
 394                             uriFormat (drop (length fullUriStr - postChars) fullUriStr)
 395                         else uriFormat fullUriStr
 396                 in uriStr ++
 397                     (if null idStr then "" else colour Green idStr)
 398             prompt :: Int -> String
 399             prompt maxPromptWidth =
 400                 ((applyIf ansi withReverseStr $ colour BoldCyan "%%%") ++)
 401                     . (" " ++) . (++ bold "> ") . unwords $ catMaybes
 402                     [ queueStatus
 403                     , uriStatus (maxPromptWidth - 5 - maybe 0 ((+1) . length) queueStatus)
 404                         . historyUri <$> curr
 405                     ]
 406         prompt . min 40 . (`div` 2) . snd <$> liftIO getTermSize
 407
 408 handleLine :: ClientOptions -> ClientState -> String -> HL.InputT ClientM Bool
 409 handleLine cOpts@ClientOptions{ cOptAnsi = ansi } s line = handle backupHandler . catchInterrupts $ case parseCommandLine line of
 410     Left err -> printErrOpt ansi err >> return False
 411     Right (CommandLine Nothing (Just (c,_))) | c `isPrefixOf` "quit" -> return True
 412     Right cline -> handleCommandLine cOpts s False cline >> return False
 413     where
 414     catchInterrupts = HL.handleInterrupt (printErrOpt ansi "Interrupted." >> return False) . HL.withInterrupt . lift
 415     backupHandler :: SomeException -> HL.InputT ClientM Bool
 416     backupHandler = (>> return False) . printErrOpt ansi . ("Unhandled exception: " <>) . show
 417
 418 data Target
 419     = TargetHistory HistoryItem
 420     | TargetFrom HistoryOrigin URI
 421     | TargetIdUri String URI
 422     | TargetUri URI
 423
 424 targetUri :: Target -> URI
 425 targetUri (TargetHistory item) = historyUri item
 426 targetUri (TargetFrom _ uri)   = uri
 427 targetUri (TargetIdUri _ uri)  = uri
 428 targetUri (TargetUri uri)      = uri
 429
 430 targetQueueItem :: Target -> QueueItem
 431 targetQueueItem (TargetFrom o uri)   = QueueURI (Just o) uri
 432 targetQueueItem (TargetHistory item) = QueueHistory item
 433 targetQueueItem i                    = QueueURI Nothing $ targetUri i
 434
 435 handleCommandLine :: ClientOptions -> ClientState -> Bool -> CommandLine -> ClientM ()
 436 handleCommandLine
 437         cOpts@(ClientOptions userDataDir interactive ansi ghost restrictedMode requestContext logH)
 438         cState@(ClientState curr jumpBack cLog visited queues _ marks sessionMarks aliases
 439             (ClientConfig defaultAction proxies geminators renderFilter preOpt linkDescFirst maxLogLen maxWrapWidth confNoConfirm verboseConnection))
 440         blockGo
 441     = \(CommandLine mt mcas) -> case mcas of
 442         Just (c,args) | Just (Alias _ (CommandLine mt' mcas')) <- lookupAlias c aliases ->
 443             let mcas'' = (, drop 1 args) . commandArgArg <$> headMay args
 444                 appendCArgs (c',as') = (c', (appendTail <$> as') ++ args)
 445                     where
 446                     appendTail arg@(CommandArg a' t') = case args of
 447                         []                   -> arg
 448                         (CommandArg _ t : _) -> CommandArg a' $ t' <> " " <> t
 449             in handleCommandLine' (mt' `mplus` mt) $
 450                 (appendCArgs <$> mcas') `mplus` mcas''
 451         _ -> handleCommandLine' mt mcas
 452
 453     where
 454
 455     -- Remark: we handle haskell's "configurations problem" by having the below all within the scope
 456     -- of the ClientOptions parameter. This is nicer to my mind than the heavier approaches of
 457     -- simulating global variables or threading a Reader monad throughout. The downside is that this
 458     -- module can't be split as much as it ought to be.
 459     -- Similar remarks go for `GeminiProtocol.makeRequest`.
 460
 461     onRestriction :: IO ()
 462     onRestriction = printErr "This is not allowed in restricted mode."
 463
 464     doRestricted :: Monoid a => RestrictedIO a -> IO a
 465     doRestricted m | restrictedMode = onRestriction >> return mempty
 466         | otherwise = RunExternal.runRestrictedIO m
 467
 468     doRestrictedAlt :: Alternative f => RestrictedIO (f a) -> IO (f a)
 469     doRestrictedAlt m | restrictedMode = onRestriction >> return empty
 470         | otherwise = RunExternal.runRestrictedIO m
 471
 472     doRestrictedFilter :: (a -> RestrictedIO a) -> (a -> IO a)
 473     doRestrictedFilter f | restrictedMode = \a -> do
 474             onRestriction
 475             return a
 476         | otherwise = RunExternal.runRestrictedIO . f
 477
 478     printInfo :: MonadIO m => String -> m ()
 479     printInfo = printInfoOpt ansi
 480     printErr :: MonadIO m => String -> m ()
 481     printErr = printErrOpt ansi
 482
 483     printIOErr :: IOError -> IO ()
 484     printIOErr = printErr . show
 485
 486     noConfirm :: Bool
 487     noConfirm = confNoConfirm || not interactive
 488
 489     confirm :: Applicative m => m Bool -> m Bool
 490     confirm | noConfirm = const $ pure True
 491         | otherwise = id
 492
 493     promptYN = Prompt.promptYN interactive
 494
 495     colour :: MetaString a => Colour -> a -> a
 496     colour = applyIf ansi . withColourStr
 497     bold :: MetaString a => a -> a
 498     bold = applyIf ansi withBoldStr
 499
 500     isVisited :: URI -> Bool
 501     isVisited uri = S.member (hash $ show uri) visited
 502
 503     requestOfUri = requestOfProxiesAndUri proxies
 504
 505     idAtUri :: ActiveIdentities -> URI -> Maybe Identity
 506     idAtUri ais uri = findIdentity ais =<< requestOfUri uri
 507
 508     showUriRefFull :: MetaString a => Bool -> ActiveIdentities -> URI -> URIRef -> a
 509     showUriRefFull ansi' ais base ref = showUriFull ansi' ais (Just base) $ relativeTo ref base
 510
 511     showUriFull :: MetaString a => Bool -> ActiveIdentities -> Maybe URI -> URI -> a
 512     showUriFull ansi' ais base uri =
 513         let scheme = uriScheme uri
 514             handled = scheme `elem` ["gemini","file"] || M.member scheme proxies
 515             inHistory = isJust $ curr >>= flip pathItemByUri uri
 516             activeId = isJust $ idAtUri ais uri
 517             col = if inHistory && not activeId then BoldBlue else case (isVisited uri,handled) of
 518                 (True,True)   -> Yellow
 519                 (False,True)  -> BoldYellow
 520                 (True,False)  -> Red
 521                 (False,False) -> BoldRed
 522             s = case base of
 523                 Nothing -> show uri
 524                 Just b  -> show $ relativeFrom uri b
 525         in fromString (applyIf ansi' (withColourStr col) s) <> case idAtUri ais uri of
 526             Nothing    -> ""
 527             Just ident -> showIdentity ansi' ident
 528
 529     displayUri :: MetaString a => URI -> a
 530     displayUri = colour Yellow . fromString . show
 531
 532     showUri :: URI -> ClientM ()
 533     showUri uri = do
 534         ais <- gets clientActiveIdentities
 535         liftIO . putStrLn $ showUriFull ansi ais Nothing uri
 536
 537     addToLog :: URI -> ClientM ()
 538     addToLog uri = do
 539         let t = T.pack $ show uri
 540         modify $ \s -> s
 541             { clientLog = BStack.push maxLogLen t $ clientLog s
 542             , clientVisited = S.insert (hash $ show uri) $ clientVisited s }
 543         unless ghost . liftIO $ maybe (return ()) (ignoreIOErr . (`T.hPutStrLn` t)) logH
 544
 545     loggedUris = catMaybes $ (parseAbsoluteUri . escapeIRI . T.unpack <$>) $ BStack.toList cLog
 546
 547     expand :: String -> String
 548     expand = expandHelp ansi (fst <$> aliases) userDataDir
 549
 550     idsPath = userDataDir </> "identities"
 551     savesDir = userDataDir </> "saves"
 552     marksDir = userDataDir </> "marks"
 553
 554     setMark :: String -> URIWithIdName -> ClientM ()
 555     setMark mark uriId | markNameValid mark = do
 556         modify $ \s -> s { clientMarks = insertMark mark uriId $ clientMarks s }
 557         unless (mark `elem` tempMarks) . liftIO .
 558             handle printIOErr $ saveMark marksDir mark uriId
 559     setMark mark _ = printErr $ "Invalid mark name " ++ mark
 560
 561     promptInput = if ghost then promptLine else promptLineWithHistoryFile inputHistPath
 562         where inputHistPath = userDataDir </> "inputHistory"
 563
 564     handleCommandLine' :: Maybe PTarget -> Maybe (String, [CommandArg]) -> ClientM ()
 565     handleCommandLine' mt mcas = void . runMaybeT $ do
 566         ts <- case mt of
 567             Nothing -> return []
 568             Just pt -> either ((>> mzero) . printErr)
 569                 (\ts -> mapM_ addTargetId ts >> return ts) $
 570                 resolveTarget pt
 571         case mcas of
 572             Nothing -> lift $ handleBareTargets ts
 573             Just (s,as) -> do
 574                 c' <- maybe (printErr (unknownCommand s) >> mzero)
 575                     return $ normaliseCommand s
 576                 lift $ handleCommand ts (c',as)
 577         where
 578         unknownCommand s = "Unknown command \"" <> s <> "\". Type \"help\" for help."
 579         addTargetId :: Target -> MaybeT ClientM ()
 580         addTargetId (TargetIdUri idName uri) =
 581             liftIO (loadIdentity idsPath idName) >>= (\case
 582                 (Nothing, _) -> printErr ("Bad URI: " ++ show uri) >> mzero
 583                 (_, Nothing) -> printErr ("Unknown identity: " ++ showIdentityName ansi idName) >> mzero
 584                 (Just req, Just ident) -> lift $ addIdentity req ident) . (requestOfUri uri,)
 585         addTargetId _ = return ()
 586
 587     resolveTarget :: PTarget -> Either String [Target]
 588     resolveTarget PTargetCurr =
 589         (:[]) . TargetHistory <$> maybeToEither "No current location" curr
 590
 591     resolveTarget PTargetJumpBack =
 592         (:[]) . TargetHistory <$> maybeToEither "'' mark not set" jumpBack
 593
 594     resolveTarget (PTargetMark s)
 595         | Just n <- readMay s =
 596             (:[]) . TargetHistory <$> maybeToEither ("Mark not set: " <> s) (M.lookup n sessionMarks)
 597         | otherwise =
 598             (:[]) . targetOfMark <$> maybeToEither ("Unknown mark: " <> s) (lookupMark s marks)
 599             where
 600             targetOfMark (URIWithIdName uri Nothing) = TargetUri uri
 601             targetOfMark (URIWithIdName uri (Just idName)) = TargetIdUri idName uri
 602
 603     resolveTarget (PTargetLog specs) =
 604         (TargetUri <$>) <$> resolveElemsSpecs "log entry" (matchPatternOn show) loggedUris specs
 605
 606     resolveTarget (PTargetQueue qname specs) =
 607         (queueTarget <$>) <$> resolveElemsSpecs "queue item"
 608             (matchPatternOn $ show . queueUri) queue specs
 609         where
 610         queue = M.findWithDefault [] qname queues
 611         queueTarget (QueueURI Nothing uri)  = TargetUri uri
 612         queueTarget (QueueURI (Just o) uri) = TargetFrom o uri
 613         queueTarget (QueueHistory item)     = TargetHistory item
 614
 615     resolveTarget (PTargetRoot base) =
 616         (rootOf <$>) <$> resolveTarget base
 617         where
 618         rootOf :: Target -> Target
 619         rootOf (TargetHistory item)                  = rootOfItem item
 620         rootOf (TargetFrom (HistoryOrigin item _) _) = rootOfItem item
 621         rootOf t                                     = t
 622         rootOfItem item = TargetHistory . lastDef item $ historyAncestors item
 623
 624     resolveTarget (PTargetAncestors base specs) =
 625         concat <$> (mapM resolveAncestors =<< resolveTarget base)
 626         where
 627         resolveAncestors :: Target -> Either String [Target]
 628         resolveAncestors (TargetHistory item) =
 629             resolveAncestors' $ historyAncestors item
 630         resolveAncestors (TargetFrom (HistoryOrigin item _) _) =
 631             resolveAncestors' $ item : historyAncestors item
 632         resolveAncestors _ = Left "No history"
 633         resolveAncestors' hist = (TargetHistory <$>) <$>
 634             resolveElemsSpecs "ancestor" (matchPatternOn $ show . historyUri)
 635                 hist specs
 636
 637     resolveTarget (PTargetDescendants base specs) =
 638         concat <$> (mapM resolveDescendants =<< resolveTarget base)
 639         where
 640         resolveDescendants :: Target -> Either String [Target]
 641         resolveDescendants (TargetHistory item) = (TargetHistory <$>) <$>
 642             resolveElemsSpecs "descendant" (matchPatternOn $ show . historyUri)
 643                 (historyDescendants item) specs
 644         resolveDescendants _ = Left "No history"
 645
 646     resolveTarget (PTargetChild increasing noVisited base specs) =
 647         concat <$> (mapM resolveChild =<< resolveTarget base)
 648         where
 649         resolveChild (TargetHistory item) =
 650             let itemLinks = extractLinksMimed $ historyGeminatedMimedData item
 651                 b = case historyChild item of
 652                     Just (HistoryChild _ (Just b')) -> b'
 653                     _ | increasing                  -> -1
 654                     _                               -> length itemLinks
 655                 slice | increasing = zip [b+1..] $ drop (b+1) itemLinks
 656                     | otherwise = zip (reverse [0..b-1]) . reverse $ take b itemLinks
 657                 linkUnvisited (_,l) = not . isVisited $ linkUri l `relativeTo` historyUri item
 658                 slice' = applyIf noVisited (filter linkUnvisited) slice
 659             in resolveLinkSpecs False item slice' specs
 660         resolveChild _ = Left "No known links"
 661
 662     resolveTarget (PTargetLinks noVisited base specs) =
 663         concat <$> (mapM resolveLinks =<< resolveTarget base)
 664         where
 665         resolveLinks (TargetHistory item) =
 666             let itemLinks = extractLinksMimed $ historyGeminatedMimedData item
 667             in resolveLinkSpecs noVisited item (zip [0..] itemLinks) specs
 668         resolveLinks _ = Left "No known links"
 669
 670     resolveTarget (PTargetRef base s) =
 671         let makeRel r | base == PTargetCurr = r
 672             makeRel r@('/':_) = '.':r
 673             makeRel r = r
 674         in case parseUriReference . escapeIRI . escapeQueryPart $ makeRel s of
 675             Nothing -> Left $ "Failed to parse relative URI: " <> s
 676             Just ref -> map relTarget <$> resolveTarget base
 677                 where
 678                 relTarget (TargetHistory item) = TargetFrom (HistoryOrigin item Nothing) $
 679                     ref `relativeTo` historyUri item
 680                 relTarget (TargetFrom o uri) = TargetFrom o $ relativeTo ref uri
 681                 relTarget t = TargetUri . relativeTo ref $ targetUri t
 682
 683     resolveTarget (PTargetAbs s) = case parseUriAsAbsolute . escapeIRI $ escapeQueryPart s of
 684         Nothing  -> Left $ "Failed to parse URI: " <> s
 685         Just uri -> return [TargetUri uri]
 686
 687     resolveLinkSpecs :: Bool -> HistoryItem -> [(Int,Link)] -> ElemsSpecs -> Either String [Target]
 688     resolveLinkSpecs purgeVisited item slice specs =
 689         let isMatch s (_,l) = matchPattern s (show $ linkUri l) ||
 690                 matchPattern s (T.unpack $ linkDescription l)
 691             linkTarg (n,l) =
 692                 let uri = linkUri l `relativeTo` historyUri item
 693                 in if purgeVisited && isVisited uri then Nothing
 694                     else Just $ TargetFrom (HistoryOrigin item $ Just n) uri
 695         in resolveElemsSpecs "link" isMatch slice specs >>= (\case
 696             []    -> Left "No such link"
 697             targs -> return targs) . catMaybes . (linkTarg <$>)
 698
 699     matchPattern :: String -> String -> Bool
 700     matchPattern patt =
 701         let regex = mkRegexWithOpts patt True (any isUpper patt)
 702         in isJust . matchRegex regex
 703
 704     matchPatternOn :: (a -> String) -> String -> a -> Bool
 705     matchPatternOn f patt = matchPattern patt . f
 706
 707     doPage :: [T.Text] -> ClientM ()
 708     doPage ls
 709         | interactive = do
 710             (height,width) <- liftIO getTermSize
 711             let pageWidth = min maxWrapWidth (width - 4)
 712                 perPage = height - min 3 (height `div` 4)
 713                 doCmd str = get >>= \s -> doSubCommand s True str
 714             printLinesPaged pageWidth width perPage doCmd ls
 715         | otherwise = liftIO $ mapM_ T.putStrLn ls
 716
 717     parseQueueSpec :: [CommandArg] -> Maybe (String, Maybe Int)
 718     parseQueueSpec [] = Just ("", Nothing)
 719     parseQueueSpec [CommandArg a _] | Just n <- readMay a = Just ("", Just n)
 720     parseQueueSpec (CommandArg a _:as) | not (null a), all isAlpha a
 721         , Just mn <- case as of
 722             []                                       -> Just Nothing
 723             [CommandArg a' _] | Just n <- readMay a' -> Just (Just n)
 724             _                                        -> Nothing
 725         = Just (a, mn)
 726     parseQueueSpec _ = Nothing
 727
 728     handleBareTargets :: [Target] -> ClientM ()
 729     handleBareTargets [] = return ()
 730     handleBareTargets (_:_:_) =
 731         printErr "Can only go to one place at a time. Try \"show\" or \"page\"?"
 732     handleBareTargets [TargetHistory item] = goHistory item
 733     handleBareTargets [TargetFrom origin uri] = goUri False (Just origin) uri
 734     handleBareTargets [t] = goUri False Nothing $ targetUri t
 735
 736
 737     handleCommand :: [Target] -> (String, [CommandArg]) -> ClientM ()
 738     handleCommand _ (c,_) | restrictedMode && notElem c (commands True) =
 739         printErr "Command disabled in restricted mode"
 740     handleCommand [] ("help", args) = case args of
 741         []                 -> doPage . map (T.pack . expand) $ helpText
 742         CommandArg s _ : _ -> doPage . map (T.pack . expand) $ helpOn s
 743     handleCommand [] ("commands",_) = doPage $ T.pack . expand <$> commandHelpText
 744         where
 745         commandHelpText = ["Aliases:"] ++ (showAlias <$> aliases) ++
 746             ["","Commands:"] ++ (('{' :) . (<> "}") <$> commands False)
 747         showAlias (a, Alias s _) = "{" <> a <> "}: " <> s
 748
 749     handleCommand [] ("mark", []) =
 750         let ms = M.toAscList marks
 751             markLine (m, uriId) = let m' = showMinPrefix ansi (fst <$> ms) m
 752                 in T.pack $ "'" <> m' <>
 753                     replicate (max 1 $ 16 - visibleLength (T.pack m')) ' ' <>
 754                     showUriWithId uriId
 755         in doPage $ markLine <$> ms
 756     handleCommand [] ("inventory",_) = do
 757         ais <- gets clientActiveIdentities
 758         let showNumberedUri :: Bool -> T.Text -> (Int,URI) -> T.Text
 759             showNumberedUri iter s (n,uri) = s <>
 760                 (if iter && n == 1 then " "
 761                     else if iter && n == 2 then T.takeEnd 1 s
 762                     else T.pack (show n)) <>
 763                 " " <> showUriFull ansi ais Nothing uri
 764             showIteratedItem s (n,item) = showNumberedUri True s (n, historyUri item)
 765             showNumberedItem s (n,item) = showNumberedUri False s (n, historyUri item)
 766             showIteratedQueueItem s (n, QueueURI _ uri) =
 767                 showNumberedUri True s (n, uri)
 768             showIteratedQueueItem s (n, QueueHistory item) =
 769                 showNumberedUri True s (n, historyUri item) <> " {fetched}"
 770             showJumpBack :: [T.Text]
 771             showJumpBack = maybeToList $ ("'' " <>) . showUriFull ansi ais Nothing . historyUri <$> jumpBack
 772         doPage . intercalate [""] . filter (not . null) $
 773             showJumpBack :
 774             [ showIteratedQueueItem (T.pack $ qname <> "~") <$> zip [1..] queue
 775                 | (qname, queue) <- M.toList queues ]
 776             ++ [ showNumberedItem "'" <$> M.toAscList sessionMarks
 777             , (showIteratedItem "<" <$> zip [1..] (maybe [] (initSafe . historyAncestors) curr))
 778             ++ (("@  " <>) . showUriFull ansi ais Nothing . historyUri <$>
 779                 maybeToList (curr >>= lastMay . historyAncestors))
 780             , showIteratedItem ">" <$> zip [1..] (maybe [] historyDescendants curr)
 781             ]
 782     handleCommand [] ("log",_) =
 783         let showLog (n,t) = "$" <> T.pack (show n) <> " " <> colour Yellow t
 784         in doPage $ showLog <$> zip [(1::Int)..] (BStack.toList cLog)
 785     handleCommand [] ("alias", CommandArg a _ : CommandArg _ str : _) = void . runMaybeT $ do
 786         c <- either ((>>mzero) . printErr) return $ parseCommand a
 787         when (c /= a) $ printErr ("Bad alias: " <> a) >> mzero
 788         cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
 789         modify $ \s ->
 790                 s { clientAliases = insertAlias a (Alias str cl) . deleteAlias a $ clientAliases s }
 791     handleCommand [] ("alias", [CommandArg a _]) =
 792         modify $ \s -> s { clientAliases = deleteAlias a $ clientAliases s }
 793     handleCommand [] ("set", []) = liftIO $ do
 794         let (c,args) = defaultAction
 795         putStrLn $ expand "{default_action}: " <> c <>
 796             maybe "" ((" "<>) . commandArgLiteralTail) (headMay args)
 797         putStrLn $ expand "{proxies}:"
 798         printMap showHost $ M.toAscList proxies
 799         putStrLn $ expand "{geminators}:"
 800         printMap id $ second snd <$> geminators
 801         putStrLn $ expand "{render_filter}: " <> fromMaybe "" renderFilter
 802         putStrLn $ expand "{pre_display}: " <> showPreOpt preOpt
 803         putStrLn $ expand "{link_desc_first}: " <> show linkDescFirst
 804         putStrLn $ expand "{log_length}: " <> show maxLogLen
 805         putStrLn $ expand "{max_wrap_width}: " <> show maxWrapWidth
 806         putStrLn $ expand "{no_confirm}: " <> show noConfirm
 807         putStrLn $ expand "{verbose_connection}: " <> show verboseConnection
 808         where
 809             printMap :: (a -> String) -> [(String,a)] -> IO ()
 810             printMap f as = mapM_ putStrLn $
 811                 (\(k,e) -> "  " <> k <> " " <> f e) <$> as
 812     handleCommand [] ("set", CommandArg opt _ : val)
 813         | opt `isPrefixOf` "default_action" = case val of
 814             (CommandArg cmd _ : args) -> case actionOfCommand (cmd,args) of
 815                 Just _ -> modifyCConf $ \c -> c { clientConfDefaultAction = (cmd,args) }
 816                 Nothing -> printErr "Invalid action"
 817             _ -> printErr "Require value for option."
 818         | opt `isPrefixOf` "proxies" || opt `isPrefixOf` "proxy" = case val of
 819             (CommandArg scheme _ : val') ->
 820                 let f = maybe (M.delete scheme) (M.insert scheme) $
 821                         parseHost . commandArgLiteralTail =<< headMay val'
 822                 in modifyCConf $ \c -> c { clientConfProxies = f $ clientConfProxies c }
 823                     -- if only I'd allowed myself to use lenses, eh?
 824             [] -> printErr "Require mimetype to set geminator for."
 825         | opt `isPrefixOf` "geminators" = case val of
 826             (CommandArg patt _ : val') ->
 827                 let f = maybe (filter $ (/= patt) . fst)
 828                         (\v -> (++ [(patt, (mkRegexWithOpts patt True True,
 829                             commandArgLiteralTail v))])) $
 830                         headMay val'
 831                 in modifyCConf $ \c -> c { clientConfGeminators = f $ clientConfGeminators c }
 832             [] -> printErr "Require mimetype to set geminator for."
 833         | opt `isPrefixOf` "render_filter" =
 834             modifyCConf $ \c -> c { clientConfRenderFilter =
 835                 commandArgLiteralTail <$> headMay val }
 836         | opt `isPrefixOf` "pre_display" = case val of
 837             [CommandArg s _] | map toLower s `isPrefixOf` "both" ->
 838                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptBoth }
 839             [CommandArg s _] | map toLower s `isPrefixOf` "pre" ->
 840                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptPre }
 841             [CommandArg s _] | map toLower s `isPrefixOf` "alt" ->
 842                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptAlt }
 843             _ -> printErr "Require \"both\" or \"pre\" or \"alt\" for pre_display"
 844         | opt `isPrefixOf` "link_desc_first" = case val of
 845             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 846                 modifyCConf $ \c -> c { clientConfLinkDescFirst = True }
 847             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 848                 modifyCConf $ \c -> c { clientConfLinkDescFirst = False }
 849             _ -> printErr "Require \"true\" or \"false\" as value for link_desc_first"
 850         | opt `isPrefixOf` "log_length" = case val of
 851             [CommandArg s _] | Just n <- readMay s, n >= 0 -> do
 852                 modifyCConf $ \c -> c { clientConfMaxLogLen = n }
 853                 modify $ \st -> st { clientLog = BStack.truncate n $ clientLog st }
 854             _ -> printErr "Require non-negative integer value for log_length"
 855         | opt `isPrefixOf` "max_wrap_width" = case val of
 856             [CommandArg s _] | Just n <- readMay s, n > 0 ->
 857                 modifyCConf $ \c -> c { clientConfMaxWrapWidth = n }
 858             _ -> printErr "Require positive integer value for max_wrap_width"
 859         | opt `isPrefixOf` "no_confirm" = case val of
 860             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 861                 modifyCConf $ \c -> c { clientConfNoConfirm = True }
 862             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 863                 modifyCConf $ \c -> c { clientConfNoConfirm = False }
 864             _ -> printErr "Require \"true\" or \"false\" as value for no_confirm"
 865         | opt `isPrefixOf` "verbose_connection" = case val of
 866             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 867                 modifyCConf $ \c -> c { clientConfVerboseConnection = True }
 868             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 869                 modifyCConf $ \c -> c { clientConfVerboseConnection = False }
 870             _ -> printErr "Require \"true\" or \"false\" as value for verbose_connection"
 871         | otherwise = printErr $ "No such option \"" <> opt <> "\"."
 872     handleCommand [] cargs =
 873         case curr of
 874             Just item -> handleCommand [TargetHistory item] cargs
 875             Nothing -> printErr "No current location. Enter an URI, or type \"help\"."
 876
 877     handleCommand ts ("add", args) = case parseQueueSpec args of
 878         Nothing          -> printErr "Bad arguments to 'add'."
 879         Just (qname, mn) -> enqueue qname mn $ targetQueueItem <$> ts
 880
 881     handleCommand ts ("fetch", args) = case parseQueueSpec args of
 882         Nothing -> printErr "Bad arguments to 'fetch."
 883         Just (qname, mn) -> do
 884             -- XXX: we have to use an IORef to store the items, since
 885             -- CommandAction doesn't allow a return value.
 886             lRef <- liftIO $ newIORef []
 887             let add item = liftIO $ slurpItem item >> modifyIORef lRef (item:)
 888             forM_ ts $ \t -> case t of
 889                 TargetHistory item -> add item
 890                 _ -> dropUriFromQueues uri >> doRequestUri uri add
 891                     where uri = targetUri t
 892             l <- liftIO $ reverse <$> readIORef lRef
 893             enqueue qname mn $ QueueHistory <$> l
 894
 895     handleCommand ts cargs =
 896         mapM_ handleTargetCommand ts
 897         where
 898         handleTargetCommand (TargetHistory item) | Just action <- actionOfCommand cargs =
 899             action item
 900         handleTargetCommand t | Just action <- actionOfCommand cargs =
 901             let uri = targetUri t
 902             in dropUriFromQueues uri >> doRequestUri uri action
 903         handleTargetCommand (TargetHistory item) | ("repeat",_) <- cargs =
 904             goUri True (recreateOrigin <$> historyParent item) $ historyUri item
 905         handleTargetCommand (TargetHistory item) | ("repl",_) <- cargs =
 906             repl (recreateOrigin <$> historyParent item) $ historyUri item
 907         handleTargetCommand (TargetHistory item) =
 908             handleUriCommand (historyUri item) cargs
 909         handleTargetCommand t =
 910             handleUriCommand (targetUri t) cargs
 911
 912         recreateOrigin :: HistoryItem -> HistoryOrigin
 913         recreateOrigin parent = HistoryOrigin parent $ childLink =<< historyChild parent
 914
 915         handleUriCommand uri ("delete",[]) = dropUriFromQueue "" uri
 916         handleUriCommand uri ("delete",CommandArg qname _ : _) = dropUriFromQueue qname uri
 917         handleUriCommand uri ("repeat",_) = goUri True Nothing uri
 918         handleUriCommand uri ("uri",_) = showUri uri
 919         handleUriCommand uri ("mark", CommandArg mark _ : _)
 920             | Just _ <- readMay mark :: Maybe Int = error "Bad mark for uri"
 921             | otherwise = do
 922             ais <- gets clientActiveIdentities
 923             let mIdName = case findIdentity ais =<< requestOfUri uri of
 924                     Just ident | not $ isTemporary ident -> Just $ identityName ident
 925                     _ -> Nothing
 926             setMark mark $ URIWithIdName uri mIdName
 927         handleUriCommand uri ("identify", args) = case requestOfUri uri of
 928             Nothing -> printErr "Bad URI"
 929             Just req -> gets ((`findIdentityRoot` req) . clientActiveIdentities) >>= \case
 930                 Just (root,(ident,_)) | null args -> endIdentityPrompted root ident
 931                 _ -> void . runMaybeT $ do
 932                     ident <- MaybeT . liftIO $ case args of
 933                         CommandArg idName _ : args' ->
 934                             let tp = case args' of
 935                                     CommandArg ('e':'d':_) _ : _ -> KeyEd25519
 936                                     _                            -> KeyRSA
 937                             in getIdentity interactive ansi idsPath tp idName
 938                         [] -> if interactive
 939                             then getIdentityRequesting ansi idsPath
 940                             else getIdentity interactive ansi idsPath KeyRSA ""
 941                     lift $ addIdentity req ident
 942         handleUriCommand uri ("browse", args) = void . liftIO . runMaybeT $ do
 943             cmd <- case args of
 944                 [] -> maybe notSet
 945                     (\s -> if null s then notSet else return $ parseBrowser s) =<<
 946                         lift (lookupEnv "BROWSER")
 947                     where
 948                     notSet = printErr "Please set $BROWSER or give a command to run" >> mzero
 949                     -- |based on specification for $BROWSER in 'man 1 man'
 950                     parseBrowser :: String -> String
 951                     parseBrowser = subPercentOrAppend (show uri) . takeWhile (/=':')
 952                 (CommandArg _ c : _) -> return $ subPercentOrAppend (show uri) c
 953             lift $ confirm (confirmShell "Run" cmd) >>? doRestricted $ void (runShellCmd cmd [])
 954         handleUriCommand uri ("repl",_) = repl Nothing uri
 955         handleUriCommand uri ("query", CommandArg _ str : _) =
 956                     goUri True Nothing . setQuery ('?':escapeQuery str) $ uri
 957         handleUriCommand uri ("log",_) = addToLog uri >> dropUriFromQueues uri
 958
 959         handleUriCommand _ (c,_) = printErr $ "Bad arguments to command " <> c
 960
 961         repl :: Maybe HistoryOrigin -> URI -> ClientM ()
 962         repl origin uri = repl' where
 963             repl' = liftIO (join <$> promptInput ">> ") >>= \case
 964                 Nothing -> return ()
 965                 Just query -> do
 966                     goUri True origin . setQuery ('?':escapeQuery query) $ uri
 967                     repl'
 968
 969     slurpItem :: HistoryItem -> IO ()
 970     slurpItem item = slurpNoisily (historyRequestTime item) . mimedBody $ historyMimedData item
 971
 972     actionOnRendered :: Bool -> ([T.Text] -> ClientM ()) -> CommandAction
 973     actionOnRendered ansi' m item = do
 974         ais <- gets clientActiveIdentities
 975         liftIO (renderMimed ansi' (historyUri item) ais (historyGeminatedMimedData item)) >>=
 976             either printErr m
 977
 978     actionOfCommand :: (String, [CommandArg]) -> Maybe CommandAction
 979     actionOfCommand (c,_) | restrictedMode && notElem c (commands True) = Nothing
 980     actionOfCommand ("show",_) = Just . actionOnRendered ansi $ liftIO . mapM_ T.putStrLn
 981     actionOfCommand ("page",_) = Just $ actionOnRendered ansi doPage
 982     actionOfCommand ("links",_) = Just $ \item -> do
 983         ais <- gets clientActiveIdentities
 984         let cl = childLink =<< historyChild item
 985             linkLine n (Link uri desc) =
 986                 applyIf (cl == Just (n-1)) (bold "* " <>) $
 987                 T.pack ('[' : show n ++ "] ")
 988                     <> showUriRefFull ansi ais (historyUri item) uri
 989                     <> if T.null desc then "" else " " <>
 990                         applyIf ansi (withColourStr Cyan) desc
 991         doPage . zipWith linkLine [1..] . extractLinksMimed . historyGeminatedMimedData $ item
 992
 993     actionOfCommand ("mark", CommandArg mark _ : _) |
 994         Just n <- readMay mark :: Maybe Int = Just $ \item -> do
 995             liftIO $ slurpItem item
 996             modify $ \s -> s { clientSessionMarks = M.insert n item $ clientSessionMarks s }
 997     actionOfCommand ("mime",_) = Just $ liftIO . putStrLn . showMimeType . historyMimedData
 998     actionOfCommand ("save", []) = actionOfCommand ("save", [CommandArg "" savesDir])
 999     actionOfCommand ("save", CommandArg _ path : _) = Just $ \item -> liftIO . doRestricted . RestrictedIO $ do
1000         createDirectoryIfMissing True savesDir
1001         homePath <- getHomeDirectory
1002         let path'
1003                 | take 2 path == "~/" = homePath </> drop 2 path
1004                 | take 1 path == "/" || take 2 path == "./" || take 3 path == "../" = path
1005                 | otherwise = savesDir </> path
1006             body = mimedBody $ historyMimedData item
1007             uri = historyUri item
1008             name = fromMaybe (fromMaybe "" $ uriRegName uri) . lastMay .
1009                 filter (not . null) $ pathSegments uri
1010         handle printIOErr . void . runMaybeT $ do
1011             lift $ mkdirhierto path'
1012             isDir <- lift $ doesDirectoryExist path'
1013             let fullpath = if isDir then path' </> name else path'
1014             lift (doesDirectoryExist fullpath) >>? do
1015                 lift . printErr $ "Path " ++ show fullpath ++ " exists and is directory"
1016                 mzero
1017             lift (doesFileExist fullpath) >>?
1018                 guard =<< lift (promptYN False $ "Overwrite " ++ show fullpath ++ "?")
1019             lift $ do
1020                 putStrLn $ "Saving to " ++ fullpath
1021                 t0 <- timeCurrentP
1022                 BL.writeFile fullpath =<< interleaveProgress t0 body
1023
1024     actionOfCommand ("!", CommandArg _ cmd : _) = Just $ \item -> liftIO . handle printIOErr . doRestricted .
1025         shellOnData noConfirm cmd userDataDir (historyEnv item) . mimedBody $ historyMimedData item
1026
1027     actionOfCommand ("view",_) = Just $ \item ->
1028         let mimed = historyMimedData item
1029             mimetype = showMimeType mimed
1030             body = mimedBody mimed
1031         in liftIO . handle printIOErr . doRestricted $ runMailcap noConfirm "view" userDataDir mimetype body
1032     actionOfCommand ("|", CommandArg _ cmd : _) = Just $ \item -> liftIO . handle printIOErr . doRestricted $
1033         pipeToShellLazily cmd (historyEnv item) . mimedBody $ historyMimedData item
1034     actionOfCommand ("||", args) = Just $ pipeRendered ansi args
1035     actionOfCommand ("||-", args) = Just $ pipeRendered False args
1036     actionOfCommand ("cat",_) = Just $ liftIO . BL.putStr . mimedBody . historyMimedData
1037     actionOfCommand ("at", CommandArg _ str : _) = Just $ \item ->
1038         doSubCommand (cState { clientCurrent = Just item }) blockGo str
1039     actionOfCommand _ = Nothing
1040
1041     pipeRendered :: Bool -> [CommandArg] -> CommandAction
1042     pipeRendered ansi' args item = (\action -> actionOnRendered ansi' action item) $ \ls ->
1043         liftIO . void . runMaybeT $ do
1044             cmd <- case args of
1045                 [] -> maybe notSet
1046                     (\s -> if null s then notSet else return s) =<<
1047                     liftIO (lookupEnv "PAGER")
1048                     where
1049                     notSet = printErr "Please set $PAGER or give a command to run" >> mzero
1050                 (CommandArg _ cmd : _) -> return cmd
1051             lift . doRestricted . pipeToShellLazily cmd (historyEnv item) . T.encodeUtf8 $ T.unlines ls
1052
1053     doSubCommand :: ClientState -> Bool -> String -> ClientM ()
1054     doSubCommand s block str = void . runMaybeT $ do
1055         cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
1056         lift $ handleCommandLine cOpts s block cl
1057
1058     setCurr :: HistoryItem -> ClientM ()
1059     setCurr i =
1060         let isJump = isNothing $ curr >>= pathItemByUri i . historyUri
1061         in do
1062             when isJump $ modify $ \s -> s { clientJumpBack = curr }
1063             modify $ \s -> s { clientCurrent = Just i }
1064
1065     doDefault :: HistoryItem -> ClientM ()
1066     doDefault item =
1067         maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction
1068
1069     goHistory :: HistoryItem -> ClientM ()
1070     goHistory _ | blockGo = printErr "Can't go anywhere now."
1071     goHistory item = do
1072         dropUriFromQueues uri
1073         showUri uri
1074         setCurr item
1075         doDefault item
1076         where uri = historyUri item
1077
1078     goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM ()
1079     goUri _ _ _ | blockGo = printErr "Can't go anywhere now."
1080     goUri forceRequest origin uri = do
1081         dropUriFromQueues uri
1082         activeId <- gets $ isJust . (`idAtUri` uri) . clientActiveIdentities
1083         case curr >>= flip pathItemByUri uri of
1084             Just i' | not (activeId || forceRequest) -> goHistory i'
1085             _ -> doRequestUri uri $ \item -> do
1086                 let updateParent i =
1087                         -- Lazily recursively update the links in the doubly linked list
1088                         let i' = i { historyParent = updateParent . updateChild i' <$> historyParent i }
1089                         in i'
1090                     updateChild i' i = i { historyChild = setChild <$> historyChild i }
1091                         where setChild c = c { childItem = i' }
1092                     glueOrigin (HistoryOrigin o l) = updateParent $ o { historyChild = Just $ HistoryChild item' l }
1093                     item' = item { historyParent = glueOrigin <$> origin }
1094                 setCurr item'
1095                 doDefault item
1096                 liftIO $ slurpItem item
1097
1098     doRequestUri :: URI -> CommandAction -> ClientM ()
1099     doRequestUri uri0 action = doRequestUri' 0 uri0
1100         where
1101         doRequestUri' redirs uri
1102             | Just req <- requestOfUri uri = addToLog uri >> doRequest redirs req
1103             | otherwise = printErr $ "Bad URI: " ++ displayUri uri ++ (
1104                     let scheme = uriScheme uri
1105                     in if scheme /= "gemini" && isNothing (M.lookup scheme proxies)
1106                     then " : No proxy set for non-gemini scheme " ++ scheme ++ "; use \"browse\"?"
1107                     else "")
1108
1109         doRequest :: Int -> Request -> ClientM ()
1110         doRequest redirs _ | redirs > 5 =
1111             printErr "Too many redirections!"
1112         doRequest redirs req@(NetworkRequest _ uri) = do
1113             (mId, ais) <- liftIO . useActiveIdentity noConfirm ansi req =<< gets clientActiveIdentities
1114             modify $ \s -> s { clientActiveIdentities = ais }
1115             printInfo $ ">>> " ++ showUriFull ansi ais Nothing uri
1116             let respBuffSize = 2 ^ (15::Int) -- 32KB max cache for response stream
1117             liftIO (makeRequest requestContext mId respBuffSize verboseConnection req)
1118                 `bracket` either (\_ -> return ()) (liftIO . snd) $
1119                 either
1120                     (printErr . displayException)
1121                     (handleResponse . fst)
1122             where
1123             handleResponse :: Response -> ClientM ()
1124             handleResponse (Input isPass prompt) = do
1125                 let defaultPrompt = "[" ++ (if isPass then "PASSWORD" else "INPUT") ++ "]"
1126                 (liftIO . (join <$>) . promptInput $
1127                         (if null prompt then defaultPrompt else prompt) ++ " > ") >>= \case
1128                     Nothing -> return ()
1129                     Just query -> doRequestUri' redirs . setQuery ('?':escapeQuery query) $ uri
1130
1131             handleResponse (Success mimedData) = doAction req mimedData
1132
1133             handleResponse (Redirect isPerm to) = do
1134                 ais <- gets clientActiveIdentities
1135                 let uri' = to `relativeTo` uri
1136                     crossSite = uriRegName uri' /= uriRegName uri
1137                     crossScheme = uriScheme uri' /= uriScheme uri
1138                     [fromId,toId] = idAtUri ais <$> [uri,uri']
1139                     crossScope = isJust toId && fromId /= toId
1140                     warningStr = colour BoldRed
1141                 proceed <- (isJust <$>) . lift . runMaybeT $ do
1142                     when crossSite $ guard <=< (liftIO . promptYN False) $
1143                         warningStr "Follow cross-site redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
1144                     when crossScheme $ guard <=< (liftIO . promptYN False) $
1145                         warningStr "Follow cross-protocol redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
1146                     when crossScope $ guard <=< (liftIO . promptYN False) $
1147                         warningStr "Follow redirect with identity " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
1148                 when proceed $ do
1149                     when (isPerm && not ghost) . mapM_ (updateMark uri') . marksWithUri uri =<< gets clientMarks
1150                     doRequestUri' (redirs + 1) uri'
1151                 where updateMark uri' (mark,uriId) = do
1152                         conf <- confirm . liftIO . promptYN True $ "Update mark '" <> mark <> " to " <> show uri' <> " ?"
1153                         when conf . setMark mark $ uriId { uriIdUri = uri' }
1154             handleResponse (Failure code info) | 60 <= code && code <= 69 = void . runMaybeT $ do
1155                 identity <- do
1156                         liftIO . putStrLn $ (case code of
1157                             60 -> "Server requests identification"
1158                             _ -> "Server rejects provided identification certificate" ++
1159                                 (if code == 61 then " as unauthorised" else if code == 62 then " as invalid" else ""))
1160                             ++ if null info then "" else ": " ++ info
1161                         guard interactive
1162                         MaybeT . liftIO $ getIdentityRequesting ansi idsPath
1163                 lift $ do
1164                     addIdentity req identity
1165                     doRequest redirs req
1166
1167             handleResponse (Failure code info) =
1168                 printErr $ "Server returns failure: " ++ show code ++ " " ++ info
1169             handleResponse (MalformedResponse malformation) =
1170                 printErr $ "Malformed response from server: " ++ show malformation
1171
1172         doRequest redirs (LocalFileRequest path) | redirs > 0 = printErr "Ignoring redirect to local file."
1173             | otherwise = void . runMaybeT $ do
1174                 (path', mimedData) <- MaybeT . liftIO . doRestrictedAlt . RestrictedIO . warnIOErrAlt $ do
1175                     let detectExtension = case takeExtension path of
1176                             -- |certain crucial filetypes we can't rely on magic to detect:
1177                             s | s `elem` [".gmi", ".gem", ".gemini"] -> Just "text/gemini"
1178                             ".md" -> Just "text/markdown"
1179                             ".html" -> Just "text/html"
1180                             _ -> Nothing
1181 #ifdef MAGIC
1182                         detectPlain "text/plain" = fromMaybe "text/plain" detectExtension
1183                         detectPlain s = s
1184                     magic <- Magic.magicOpen [Magic.MagicMimeType]
1185                     Magic.magicLoadDefault magic
1186                     s <- detectPlain <$> Magic.magicFile magic path
1187 #else
1188                     let s = if "/" `isSuffixOf` path then "inode/directory"
1189                             else fromMaybe "application/octet-stream" detectExtension
1190 #endif
1191                     case MIME.parseMIMEType $ TS.pack s of
1192                         Nothing -> printErr ("Failed to parse mimetype string: " <> s) >> return Nothing
1193                         _ | s == "inode/directory" -> Just . (slashedPath,) . MimedData gemTextMimeType .
1194                             T.encodeUtf8 . T.unlines .
1195                             ((("=> " <>) . T.pack . escapePathString) <$>) . sort <$>
1196                                 getDirectoryContents path
1197                             where slashedPath | "/" `isSuffixOf` path = path
1198                                     | otherwise = path <> "/"
1199                         Just mimetype -> Just . (path,) . MimedData mimetype <$> BL.readFile path
1200                 lift $ doAction (LocalFileRequest path') mimedData
1201
1202         doAction req mimedData = do
1203             t0 <- liftIO timeCurrentP
1204             geminated <- geminate mimedData
1205             action $ HistoryItem req t0 mimedData geminated Nothing Nothing
1206             where
1207             -- |returns MimedData with lazy IO
1208             geminate :: MimedData -> ClientM MimedData
1209             geminate mimed =
1210                 let geminator = lookupGeminator $ showMimeType mimed
1211                 in liftIO . unsafeInterleaveIO $ applyGeminator geminator
1212                 where
1213                 lookupGeminator mimetype =
1214                     listToMaybe [ gem | (_, (regex, gem)) <- geminators
1215                         , isJust $ matchRegex regex mimetype ]
1216                 applyGeminator Nothing = return mimed
1217                 applyGeminator (Just cmd) =
1218                     printInfo ("| " <> cmd) >>
1219                     MimedData gemTextMimeType <$>
1220                         doRestrictedFilter (filterShell cmd [("URI", show $ requestUri req)]) (mimedBody mimed)
1221
1222         gemTextMimeType :: MIME.Type
1223         gemTextMimeType = MIME.Type (MIME.Text "gemini") []
1224
1225
1226     addIdentity :: Request -> Identity -> ClientM ()
1227     addIdentity req identity = do
1228         ais <- gets clientActiveIdentities >>= liftIO . insertIdentity req identity
1229         modify $ \s -> s {clientActiveIdentities = ais}
1230     endIdentityPrompted :: Request -> Identity -> ClientM ()
1231     endIdentityPrompted root ident = do
1232         conf <- confirm $ liftIO . promptYN False $ "Stop using " ++
1233             (if isTemporary ident then "temporary anonymous identity" else showIdentity ansi ident) ++
1234             " at " ++ displayUri (requestUri root) ++ "?"
1235         when conf . modify $ \s ->
1236                 s { clientActiveIdentities = deleteIdentity root $ clientActiveIdentities s }
1237
1238     extractLinksMimed :: MimedData -> [Link]
1239     extractLinksMimed (MimedData (MIME.Type (MIME.Text "gemini") _) body) =
1240         extractLinks . parseGemini $ T.decodeUtf8With T.lenientDecode body
1241     extractLinksMimed _ = []
1242
1243     renderMimed :: Bool -> URI -> ActiveIdentities -> MimedData -> IO (Either String [T.Text])
1244     renderMimed ansi' uri ais (MimedData mime body) = case MIME.mimeType mime of
1245         MIME.Text textType -> do
1246             let extractCharsetParam (MIME.MIMEParam "charset" v) = Just v
1247                 extractCharsetParam _                            = Nothing
1248                 charset = TS.unpack . fromMaybe "utf-8" . msum . map extractCharsetParam $ MIME.mimeParams mime
1249                 isUtf8 = map toLower charset `elem` ["utf-8", "utf8"]
1250 #ifdef ICONV
1251                 reencoder = if isUtf8 then id else
1252                     convert charset "UTF-8"
1253 #else
1254                 reencoder = id
1255             unless isUtf8 . printErr $
1256                 "Warning: Treating unsupported charset " ++ show charset ++ " as utf-8"
1257 #endif
1258             (_,width) <- getTermSize
1259             let pageWidth = if interactive
1260                 then min maxWrapWidth (width - 4)
1261                 else maxWrapWidth
1262             let bodyText = T.decodeUtf8With T.lenientDecode $ reencoder body
1263                 applyFilter :: [T.Text] -> IO [T.Text]
1264                 applyFilter = case renderFilter of
1265                     Nothing -> return
1266                     Just cmd -> (T.lines . T.decodeUtf8With T.lenientDecode <$>) .
1267                         doRestrictedFilter (filterShell cmd []) . BL.concat . (appendNewline . T.encodeUtf8 <$>)
1268                         where appendNewline = (`BL.snoc` 10)
1269             (Right <$>) . applyFilter . (sanitiseNonCSI <$>) $ case textType of
1270                     "gemini" ->
1271                         let opts = GemRenderOpts ansi' preOpt pageWidth linkDescFirst
1272                         in printGemDoc opts (showUriRefFull ansi' ais uri) $ parseGemini bodyText
1273                     _ -> T.stripEnd <$> T.lines bodyText
1274         mimeType ->
1275             return . Left $ "No geminator for " ++ TS.unpack (MIME.showMIMEType mimeType) ++ " configured. Try \"save\", \"view\", \"!\", or \"|\"?"