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