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 && Batch `notElem` opts) || 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 | markNameValid mark = 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     setMark mark _ = printErr $ "Invalid mark name " ++ mark
 572
 573     promptInput = if ghost then promptLine else promptLineWithHistoryFile inputHistPath
 574         where inputHistPath = userDataDir </> "inputHistory"
 575
 576     handleCommandLine' :: Maybe PTarget -> Maybe (String, [CommandArg]) -> ClientM ()
 577     handleCommandLine' mt mcas = void . runMaybeT $ do
 578         ts <- case mt of
 579             Nothing -> return []
 580             Just pt -> either ((>> mzero) . printErr)
 581                 (\ts -> mapM_ addTargetId ts >> return ts) $
 582                 resolveTarget pt
 583         case mcas of
 584             Nothing -> lift $ handleBareTargets ts
 585             Just (s,as) -> do
 586                 c' <- maybe (printErr (unknownCommand s) >> mzero)
 587                     return $ normaliseCommand s
 588                 lift $ handleCommand ts (c',as)
 589         where
 590         unknownCommand s = "Unknown command \"" <> s <> "\". Type \"help\" for help."
 591         addTargetId :: Target -> MaybeT ClientM ()
 592         addTargetId (TargetIdUri idName uri) =
 593             liftIO (loadIdentity idsPath idName) >>= (\case
 594                 (Nothing, _) -> printErr ("Bad URI: " ++ show uri) >> mzero
 595                 (_, Nothing) -> printErr ("Unknown identity: " ++ showIdentityName ansi idName) >> mzero
 596                 (Just req, Just ident) -> lift $ addIdentity req ident) . (requestOfUri uri,)
 597         addTargetId _ = return ()
 598
 599     resolveTarget :: PTarget -> Either String [Target]
 600     resolveTarget PTargetCurr =
 601         (:[]) . TargetHistory <$> maybeToEither "No current location" curr
 602
 603     resolveTarget PTargetJumpBack =
 604         (:[]) . TargetHistory <$> maybeToEither "'' mark not set" jumpBack
 605
 606     resolveTarget (PTargetMark s)
 607         | Just n <- readMay s =
 608             (:[]) . TargetHistory <$> maybeToEither ("Mark not set: " <> s) (M.lookup n sessionMarks)
 609         | otherwise =
 610             (:[]) . targetOfMark <$> maybeToEither ("Unknown mark: " <> s) (lookupMark s marks)
 611             where
 612             targetOfMark (URIWithIdName uri Nothing) = TargetUri uri
 613             targetOfMark (URIWithIdName uri (Just idName)) = TargetIdUri idName uri
 614
 615     resolveTarget (PTargetLog specs) =
 616         (TargetUri <$>) <$> resolveElemsSpecs "log entry" (matchPatternOn show) loggedUris specs
 617
 618     resolveTarget (PTargetQueue qname specs) =
 619         (queueTarget <$>) <$> resolveElemsSpecs "queue item"
 620             (matchPatternOn $ show . queueUri) queue specs
 621         where
 622         queue = M.findWithDefault [] qname queues
 623         queueTarget (QueueURI Nothing uri)  = TargetUri uri
 624         queueTarget (QueueURI (Just o) uri) = TargetFrom o uri
 625         queueTarget (QueueHistory item)     = TargetHistory item
 626
 627     resolveTarget (PTargetRoot base) =
 628         (rootOf <$>) <$> resolveTarget base
 629         where
 630         rootOf :: Target -> Target
 631         rootOf (TargetHistory item)                  = rootOfItem item
 632         rootOf (TargetFrom (HistoryOrigin item _) _) = rootOfItem item
 633         rootOf t                                     = t
 634         rootOfItem item = TargetHistory . lastDef item $ historyAncestors item
 635
 636     resolveTarget (PTargetAncestors base specs) =
 637         concat <$> (mapM resolveAncestors =<< resolveTarget base)
 638         where
 639         resolveAncestors :: Target -> Either String [Target]
 640         resolveAncestors (TargetHistory item) =
 641             resolveAncestors' $ historyAncestors item
 642         resolveAncestors (TargetFrom (HistoryOrigin item _) _) =
 643             resolveAncestors' $ item : historyAncestors item
 644         resolveAncestors _ = Left "No history"
 645         resolveAncestors' hist = (TargetHistory <$>) <$>
 646             resolveElemsSpecs "ancestor" (matchPatternOn $ show . historyUri)
 647                 hist specs
 648
 649     resolveTarget (PTargetDescendants base specs) =
 650         concat <$> (mapM resolveDescendants =<< resolveTarget base)
 651         where
 652         resolveDescendants :: Target -> Either String [Target]
 653         resolveDescendants (TargetHistory item) = (TargetHistory <$>) <$>
 654             resolveElemsSpecs "descendant" (matchPatternOn $ show . historyUri)
 655                 (historyDescendants item) specs
 656         resolveDescendants _ = Left "No history"
 657
 658     resolveTarget (PTargetChild increasing noVisited base specs) =
 659         concat <$> (mapM resolveChild =<< resolveTarget base)
 660         where
 661         resolveChild (TargetHistory item) =
 662             let itemLinks = extractLinksMimed $ historyGeminatedMimedData item
 663                 b = case historyChild item of
 664                     Just (HistoryChild _ (Just b')) -> b'
 665                     _ | increasing                  -> -1
 666                     _                               -> length itemLinks
 667                 slice | increasing = zip [b+1..] $ drop (b+1) itemLinks
 668                     | otherwise = zip (reverse [0..b-1]) . reverse $ take b itemLinks
 669                 linkUnvisited (_,l) = not . isVisited $ linkUri l `relativeTo` historyUri item
 670                 slice' = applyIf noVisited (filter linkUnvisited) slice
 671             in resolveLinkSpecs False item slice' specs
 672         resolveChild _ = Left "No known links"
 673
 674     resolveTarget (PTargetLinks noVisited base specs) =
 675         concat <$> (mapM resolveLinks =<< resolveTarget base)
 676         where
 677         resolveLinks (TargetHistory item) =
 678             let itemLinks = extractLinksMimed $ historyGeminatedMimedData item
 679             in resolveLinkSpecs noVisited item (zip [0..] itemLinks) specs
 680         resolveLinks _ = Left "No known links"
 681
 682     resolveTarget (PTargetRef base s) =
 683         let makeRel r | base == PTargetCurr = r
 684             makeRel r@('/':_) = '.':r
 685             makeRel r = r
 686         in case parseUriReference . escapeIRI . escapeQueryPart $ makeRel s of
 687             Nothing -> Left $ "Failed to parse relative URI: " <> s
 688             Just ref -> map relTarget <$> resolveTarget base
 689                 where
 690                 relTarget (TargetHistory item) = TargetFrom (HistoryOrigin item Nothing) $
 691                     ref `relativeTo` historyUri item
 692                 relTarget (TargetFrom o uri) = TargetFrom o $ relativeTo ref uri
 693                 relTarget t = TargetUri . relativeTo ref $ targetUri t
 694
 695     resolveTarget (PTargetAbs s) = case parseUriAsAbsolute . escapeIRI $ escapeQueryPart s of
 696         Nothing  -> Left $ "Failed to parse URI: " <> s
 697         Just uri -> return [TargetUri uri]
 698
 699     resolveLinkSpecs :: Bool -> HistoryItem -> [(Int,Link)] -> ElemsSpecs -> Either String [Target]
 700     resolveLinkSpecs purgeVisited item slice specs =
 701         let isMatch s (_,l) = matchPattern s (show $ linkUri l) ||
 702                 matchPattern s (T.unpack $ linkDescription l)
 703             linkTarg (n,l) =
 704                 let uri = linkUri l `relativeTo` historyUri item
 705                 in if purgeVisited && isVisited uri then Nothing
 706                     else Just $ TargetFrom (HistoryOrigin item $ Just n) uri
 707         in resolveElemsSpecs "link" isMatch slice specs >>= (\case
 708             []    -> Left "No such link"
 709             targs -> return targs) . catMaybes . (linkTarg <$>)
 710
 711     matchPattern :: String -> String -> Bool
 712     matchPattern patt =
 713         let regex = mkRegexWithOpts patt True (any isUpper patt)
 714         in isJust . matchRegex regex
 715
 716     matchPatternOn :: (a -> String) -> String -> a -> Bool
 717     matchPatternOn f patt = matchPattern patt . f
 718
 719     doPage :: [T.Text] -> ClientM ()
 720     doPage ls
 721         | interactive = do
 722         (height,width) <- liftIO getTermSize
 723         let pageWidth = min maxWrapWidth (width - 4)
 724         let perPage = height - min 3 (height `div` 4)
 725         queued <- liftIO $ printLinesPaged pageWidth width perPage ls
 726         modify $ \s -> s { clientQueuedCommands = clientQueuedCommands s ++ queued }
 727         | otherwise = liftIO $ mapM_ T.putStrLn ls
 728
 729     parseQueueSpec :: [CommandArg] -> Maybe (String, Maybe Int)
 730     parseQueueSpec [] = Just ("", Nothing)
 731     parseQueueSpec [CommandArg a _] | Just n <- readMay a = Just ("", Just n)
 732     parseQueueSpec (CommandArg a _:as) | not (null a), all isAlpha a
 733         , Just mn <- case as of
 734             []                                       -> Just Nothing
 735             [CommandArg a' _] | Just n <- readMay a' -> Just (Just n)
 736             _                                        -> Nothing
 737         = Just (a, mn)
 738     parseQueueSpec _ = Nothing
 739
 740     handleBareTargets :: [Target] -> ClientM ()
 741     handleBareTargets [] = return ()
 742     handleBareTargets (_:_:_) =
 743         printErr "Can only go to one place at a time. Try \"show\" or \"page\"?"
 744     handleBareTargets [TargetHistory item] = goHistory item
 745     handleBareTargets [TargetFrom origin uri] = goUri False (Just origin) uri
 746     handleBareTargets [t] = goUri False Nothing $ targetUri t
 747
 748
 749     handleCommand :: [Target] -> (String, [CommandArg]) -> ClientM ()
 750     handleCommand _ (c,_) | restrictedMode && notElem c (commands True) =
 751         printErr "Command disabled in restricted mode"
 752     handleCommand [] ("help", args) = case args of
 753         []                 -> doPage . map (T.pack . expand) $ helpText
 754         CommandArg s _ : _ -> doPage . map (T.pack . expand) $ helpOn s
 755     handleCommand [] ("commands",_) = doPage $ T.pack . expand <$> commandHelpText
 756         where
 757         commandHelpText = ["Aliases:"] ++ (showAlias <$> aliases) ++
 758             ["","Commands:"] ++ (('{' :) . (<> "}") <$> commands False)
 759         showAlias (a, Alias s _) = "{" <> a <> "}: " <> s
 760
 761     handleCommand [] ("mark", []) =
 762         let ms = M.toAscList marks
 763             markLine (m, uriId) = let m' = showMinPrefix ansi (fst <$> ms) m
 764                 in T.pack $ "'" <> m' <>
 765                     replicate (max 1 $ 16 - visibleLength (T.pack m')) ' ' <>
 766                     showUriWithId uriId
 767         in doPage $ markLine <$> ms
 768     handleCommand [] ("inventory",_) = do
 769         ais <- gets clientActiveIdentities
 770         let showNumberedUri :: Bool -> T.Text -> (Int,URI) -> T.Text
 771             showNumberedUri iter s (n,uri) = s <>
 772                 (if iter && n == 1 then " "
 773                     else if iter && n == 2 then T.takeEnd 1 s
 774                     else T.pack (show n)) <>
 775                 " " <> showUriFull ansi ais Nothing uri
 776             showIteratedItem s (n,item) = showNumberedUri True s (n, historyUri item)
 777             showNumberedItem s (n,item) = showNumberedUri False s (n, historyUri item)
 778             showIteratedQueueItem s (n, QueueURI _ uri) =
 779                 showNumberedUri True s (n, uri)
 780             showIteratedQueueItem s (n, QueueHistory item) =
 781                 showNumberedUri True s (n, historyUri item) <> " {fetched}"
 782             showJumpBack :: [T.Text]
 783             showJumpBack = maybeToList $ ("'' " <>) . showUriFull ansi ais Nothing . historyUri <$> jumpBack
 784         doPage . intercalate [""] . filter (not . null) $
 785             showJumpBack :
 786             [ showIteratedQueueItem (T.pack $ qname <> "~") <$> zip [1..] queue
 787                 | (qname, queue) <- M.toList queues ]
 788             ++ [ showNumberedItem "'" <$> M.toAscList sessionMarks
 789             , (showIteratedItem "<" <$> zip [1..] (maybe [] (initSafe . historyAncestors) curr))
 790             ++ (("@  " <>) . showUriFull ansi ais Nothing . historyUri <$>
 791                 maybeToList (curr >>= lastMay . historyAncestors))
 792             , showIteratedItem ">" <$> zip [1..] (maybe [] historyDescendants curr)
 793             ]
 794     handleCommand [] ("log",_) =
 795         let showLog (n,t) = "$" <> T.pack (show n) <> " " <> colour Yellow t
 796         in doPage $ showLog <$> zip [(1::Int)..] (BStack.toList cLog)
 797     handleCommand [] ("alias", CommandArg a _ : CommandArg _ str : _) = void . runMaybeT $ do
 798         c <- either ((>>mzero) . printErr) return $ parseCommand a
 799         when (c /= a) $ printErr ("Bad alias: " <> a) >> mzero
 800         cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
 801         modify $ \s ->
 802                 s { clientAliases = insertAlias a (Alias str cl) . deleteAlias a $ clientAliases s }
 803     handleCommand [] ("alias", [CommandArg a _]) =
 804         modify $ \s -> s { clientAliases = deleteAlias a $ clientAliases s }
 805     handleCommand [] ("set", []) = liftIO $ do
 806         let (c,args) = defaultAction
 807         putStrLn $ expand "{default_action}: " <> c <>
 808             maybe "" ((" "<>) . commandArgLiteralTail) (headMay args)
 809         putStrLn $ expand "{proxies}:"
 810         printMap showHost $ M.toAscList proxies
 811         putStrLn $ expand "{geminators}:"
 812         printMap id $ second snd <$> geminators
 813         putStrLn $ expand "{render_filter}: " <> fromMaybe "" renderFilter
 814         putStrLn $ expand "{pre_display}: " <> showPreOpt preOpt
 815         putStrLn $ expand "{link_desc_first}: " <> show linkDescFirst
 816         putStrLn $ expand "{log_length}: " <> show maxLogLen
 817         putStrLn $ expand "{max_wrap_width}: " <> show maxWrapWidth
 818         putStrLn $ expand "{no_confirm}: " <> show noConfirm
 819         putStrLn $ expand "{verbose_connection}: " <> show verboseConnection
 820         where
 821             printMap :: (a -> String) -> [(String,a)] -> IO ()
 822             printMap f as = mapM_ putStrLn $
 823                 (\(k,e) -> "  " <> k <> " " <> f e) <$> as
 824     handleCommand [] ("set", CommandArg opt _ : val)
 825         | opt `isPrefixOf` "default_action" = case val of
 826             (CommandArg cmd _ : args) -> case actionOfCommand (cmd,args) of
 827                 Just _ -> modifyCConf $ \c -> c { clientConfDefaultAction = (cmd,args) }
 828                 Nothing -> printErr "Invalid action"
 829             _ -> printErr "Require value for option."
 830         | opt `isPrefixOf` "proxies" || opt `isPrefixOf` "proxy" = case val of
 831             (CommandArg scheme _ : val') ->
 832                 let f = maybe (M.delete scheme) (M.insert scheme) $
 833                         parseHost . commandArgLiteralTail =<< headMay val'
 834                 in modifyCConf $ \c -> c { clientConfProxies = f $ clientConfProxies c }
 835                     -- if only I'd allowed myself to use lenses, eh?
 836             [] -> printErr "Require mimetype to set geminator for."
 837         | opt `isPrefixOf` "geminators" = case val of
 838             (CommandArg patt _ : val') ->
 839                 let f = maybe (filter $ (/= patt) . fst)
 840                         (\v -> (++ [(patt, (mkRegexWithOpts patt True True,
 841                             commandArgLiteralTail v))])) $
 842                         headMay val'
 843                 in modifyCConf $ \c -> c { clientConfGeminators = f $ clientConfGeminators c }
 844             [] -> printErr "Require mimetype to set geminator for."
 845         | opt `isPrefixOf` "render_filter" =
 846             modifyCConf $ \c -> c { clientConfRenderFilter =
 847                 commandArgLiteralTail <$> headMay val }
 848         | opt `isPrefixOf` "pre_display" = case val of
 849             [CommandArg s _] | map toLower s `isPrefixOf` "both" ->
 850                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptBoth }
 851             [CommandArg s _] | map toLower s `isPrefixOf` "pre" ->
 852                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptPre }
 853             [CommandArg s _] | map toLower s `isPrefixOf` "alt" ->
 854                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptAlt }
 855             _ -> printErr "Require \"both\" or \"pre\" or \"alt\" for pre_display"
 856         | opt `isPrefixOf` "link_desc_first" = case val of
 857             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 858                 modifyCConf $ \c -> c { clientConfLinkDescFirst = True }
 859             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 860                 modifyCConf $ \c -> c { clientConfLinkDescFirst = False }
 861             _ -> printErr "Require \"true\" or \"false\" as value for link_desc_first"
 862         | opt `isPrefixOf` "log_length" = case val of
 863             [CommandArg s _] | Just n <- readMay s, n >= 0 -> do
 864                 modifyCConf $ \c -> c { clientConfMaxLogLen = n }
 865                 modify $ \st -> st { clientLog = BStack.truncate n $ clientLog st }
 866             _ -> printErr "Require non-negative integer value for log_length"
 867         | opt `isPrefixOf` "max_wrap_width" = case val of
 868             [CommandArg s _] | Just n <- readMay s, n > 0 ->
 869                 modifyCConf $ \c -> c { clientConfMaxWrapWidth = n }
 870             _ -> printErr "Require positive integer value for max_wrap_width"
 871         | opt `isPrefixOf` "no_confirm" = case val of
 872             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 873                 modifyCConf $ \c -> c { clientConfNoConfirm = True }
 874             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 875                 modifyCConf $ \c -> c { clientConfNoConfirm = False }
 876             _ -> printErr "Require \"true\" or \"false\" as value for no_confirm"
 877         | opt `isPrefixOf` "verbose_connection" = case val of
 878             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 879                 modifyCConf $ \c -> c { clientConfVerboseConnection = True }
 880             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 881                 modifyCConf $ \c -> c { clientConfVerboseConnection = False }
 882             _ -> printErr "Require \"true\" or \"false\" as value for verbose_connection"
 883         | otherwise = printErr $ "No such option \"" <> opt <> "\"."
 884     handleCommand [] cargs =
 885         case curr of
 886             Just item -> handleCommand [TargetHistory item] cargs
 887             Nothing -> printErr "No current location. Enter an URI, or type \"help\"."
 888
 889     handleCommand ts ("add", args) = case parseQueueSpec args of
 890         Nothing          -> printErr "Bad arguments to 'add'."
 891         Just (qname, mn) -> enqueue qname mn $ targetQueueItem <$> ts
 892
 893     handleCommand ts ("fetch", args) = case parseQueueSpec args of
 894         Nothing -> printErr "Bad arguments to 'fetch."
 895         Just (qname, mn) -> do
 896             -- XXX: we have to use an IORef to store the items, since
 897             -- CommandAction doesn't allow a return value.
 898             lRef <- liftIO $ newIORef []
 899             let add item = liftIO $ slurpItem item >> modifyIORef lRef (item:)
 900             forM_ ts $ \t -> case t of
 901                 TargetHistory item -> add item
 902                 _ -> dropUriFromQueues uri >> doRequestUri uri add
 903                     where uri = targetUri t
 904             l <- liftIO $ reverse <$> readIORef lRef
 905             enqueue qname mn $ QueueHistory <$> l
 906
 907     handleCommand ts cargs =
 908         mapM_ handleTargetCommand ts
 909         where
 910         handleTargetCommand (TargetHistory item) | Just action <- actionOfCommand cargs =
 911             action item
 912         handleTargetCommand t | Just action <- actionOfCommand cargs =
 913             let uri = targetUri t
 914             in dropUriFromQueues uri >> doRequestUri uri action
 915         handleTargetCommand (TargetHistory item) | ("repeat",_) <- cargs =
 916             goUri True (recreateOrigin <$> historyParent item) $ historyUri item
 917         handleTargetCommand (TargetHistory item) | ("repl",_) <- cargs =
 918             repl (recreateOrigin <$> historyParent item) $ historyUri item
 919         handleTargetCommand (TargetHistory item) =
 920             handleUriCommand (historyUri item) cargs
 921         handleTargetCommand t =
 922             handleUriCommand (targetUri t) cargs
 923
 924         recreateOrigin :: HistoryItem -> HistoryOrigin
 925         recreateOrigin parent = HistoryOrigin parent $ childLink =<< historyChild parent
 926
 927         handleUriCommand uri ("delete",[]) = dropUriFromQueue "" uri
 928         handleUriCommand uri ("delete",CommandArg qname _ : _) = dropUriFromQueue qname uri
 929         handleUriCommand uri ("repeat",_) = goUri True Nothing uri
 930         handleUriCommand uri ("uri",_) = showUri uri
 931         handleUriCommand uri ("mark", CommandArg mark _ : _)
 932             | Just _ <- readMay mark :: Maybe Int = error "Bad mark for uri"
 933             | otherwise = do
 934             ais <- gets clientActiveIdentities
 935             let mIdName = case findIdentity ais =<< requestOfUri uri of
 936                     Just ident | not $ isTemporary ident -> Just $ identityName ident
 937                     _ -> Nothing
 938             setMark mark $ URIWithIdName uri mIdName
 939         handleUriCommand uri ("identify", args) = case requestOfUri uri of
 940             Nothing -> printErr "Bad URI"
 941             Just req -> gets ((`findIdentityRoot` req) . clientActiveIdentities) >>= \case
 942                 Just (root,(ident,_)) | null args -> endIdentityPrompted root ident
 943                 _ -> void . runMaybeT $ do
 944                     ident <- MaybeT . liftIO $ case args of
 945                         CommandArg idName _ : args' ->
 946                             let tp = case args' of
 947                                     CommandArg ('e':'d':_) _ : _ -> KeyEd25519
 948                                     _                            -> KeyRSA
 949                             in getIdentity interactive ansi idsPath tp idName
 950                         [] -> if interactive
 951                             then getIdentityRequesting ansi idsPath
 952                             else getIdentity interactive ansi idsPath KeyRSA ""
 953                     lift $ addIdentity req ident
 954         handleUriCommand uri ("browse", args) = void . liftIO . runMaybeT $ do
 955             cmd <- case args of
 956                 [] -> maybe notSet
 957                     (\s -> if null s then notSet else return $ parseBrowser s) =<<
 958                         lift (lookupEnv "BROWSER")
 959                     where
 960                     notSet = printErr "Please set $BROWSER or give a command to run" >> mzero
 961                     -- |based on specification for $BROWSER in 'man 1 man'
 962                     parseBrowser :: String -> String
 963                     parseBrowser = subPercentOrAppend (show uri) . takeWhile (/=':')
 964                 (CommandArg _ c : _) -> return $ subPercentOrAppend (show uri) c
 965             lift $ confirm (confirmShell "Run" cmd) >>? doRestricted $ void (runShellCmd cmd [])
 966         handleUriCommand uri ("repl",_) = repl Nothing uri
 967         handleUriCommand uri ("query", CommandArg _ str : _) =
 968                     goUri True Nothing . setQuery ('?':escapeQuery str) $ uri
 969         handleUriCommand uri ("log",_) = addToLog uri >> dropUriFromQueues uri
 970
 971         handleUriCommand _ (c,_) = printErr $ "Bad arguments to command " <> c
 972
 973         repl :: Maybe HistoryOrigin -> URI -> ClientM ()
 974         repl origin uri = repl' where
 975             repl' = liftIO (join <$> promptInput ">> ") >>= \case
 976                 Nothing -> return ()
 977                 Just query -> do
 978                     goUri True origin . setQuery ('?':escapeQuery query) $ uri
 979                     repl'
 980
 981     slurpItem :: HistoryItem -> IO ()
 982     slurpItem item = slurpNoisily (historyRequestTime item) . mimedBody $ historyMimedData item
 983
 984     actionOnRendered :: Bool -> ([T.Text] -> ClientM ()) -> CommandAction
 985     actionOnRendered ansi' m item = do
 986         ais <- gets clientActiveIdentities
 987         liftIO (renderMimed ansi' (historyUri item) ais (historyGeminatedMimedData item)) >>=
 988             either printErr m
 989
 990     actionOfCommand :: (String, [CommandArg]) -> Maybe CommandAction
 991     actionOfCommand (c,_) | restrictedMode && notElem c (commands True) = Nothing
 992     actionOfCommand ("show",_) = Just . actionOnRendered ansi $ liftIO . mapM_ T.putStrLn
 993     actionOfCommand ("page",_) = Just $ actionOnRendered ansi doPage
 994     actionOfCommand ("links",_) = Just $ \item -> do
 995         ais <- gets clientActiveIdentities
 996         let cl = childLink =<< historyChild item
 997             linkLine n (Link uri desc) =
 998                 applyIf (cl == Just (n-1)) (bold "* " <>) $
 999                 T.pack ('[' : show n ++ "] ")
1000                     <> showUriRefFull ansi ais (historyUri item) uri
1001                     <> if T.null desc then "" else " " <>
1002                         applyIf ansi (withColourStr Cyan) desc
1003         doPage . zipWith linkLine [1..] . extractLinksMimed . historyGeminatedMimedData $ item
1004
1005     actionOfCommand ("mark", CommandArg mark _ : _) |
1006         Just n <- readMay mark :: Maybe Int = Just $ \item -> do
1007             liftIO $ slurpItem item
1008             modify $ \s -> s { clientSessionMarks = M.insert n item $ clientSessionMarks s }
1009     actionOfCommand ("mime",_) = Just $ liftIO . putStrLn . showMimeType . historyMimedData
1010     actionOfCommand ("save", []) = actionOfCommand ("save", [CommandArg "" savesDir])
1011     actionOfCommand ("save", CommandArg _ path : _) = Just $ \item -> liftIO . doRestricted . RestrictedIO $ do
1012         createDirectoryIfMissing True savesDir
1013         homePath <- getHomeDirectory
1014         let path'
1015                 | take 2 path == "~/" = homePath </> drop 2 path
1016                 | take 1 path == "/" || take 2 path == "./" || take 3 path == "../" = path
1017                 | otherwise = savesDir </> path
1018             body = mimedBody $ historyMimedData item
1019             uri = historyUri item
1020             name = fromMaybe (fromMaybe "" $ uriRegName uri) . lastMay .
1021                 filter (not . null) $ pathSegments uri
1022         handle printIOErr . void . runMaybeT $ do
1023             lift $ mkdirhierto path'
1024             isDir <- lift $ doesDirectoryExist path'
1025             let fullpath = if isDir then path' </> name else path'
1026             lift (doesDirectoryExist fullpath) >>? do
1027                 lift . printErr $ "Path " ++ show fullpath ++ " exists and is directory"
1028                 mzero
1029             lift (doesFileExist fullpath) >>?
1030                 guard =<< lift (promptYN False $ "Overwrite " ++ show fullpath ++ "?")
1031             lift $ do
1032                 putStrLn $ "Saving to " ++ fullpath
1033                 t0 <- timeCurrentP
1034                 BL.writeFile fullpath =<< interleaveProgress t0 body
1035
1036     actionOfCommand ("!", CommandArg _ cmd : _) = Just $ \item -> liftIO . handle printIOErr . doRestricted .
1037         shellOnData noConfirm cmd userDataDir (historyEnv item) . mimedBody $ historyMimedData item
1038
1039     actionOfCommand ("view",_) = Just $ \item ->
1040         let mimed = historyMimedData item
1041             mimetype = showMimeType mimed
1042             body = mimedBody mimed
1043         in liftIO . handle printIOErr . doRestricted $ runMailcap noConfirm "view" userDataDir mimetype body
1044     actionOfCommand ("|", CommandArg _ cmd : _) = Just $ \item -> liftIO . handle printIOErr . doRestricted $
1045         pipeToShellLazily cmd (historyEnv item) . mimedBody $ historyMimedData item
1046     actionOfCommand ("||", args) = Just $ pipeRendered ansi args
1047     actionOfCommand ("||-", args) = Just $ pipeRendered False args
1048     actionOfCommand ("cat",_) = Just $ liftIO . BL.putStr . mimedBody . historyMimedData
1049     actionOfCommand ("at", CommandArg _ str : _) = Just $ \item -> void . runMaybeT $ do
1050         cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
1051         lift $ handleCommandLine cOpts (cState { clientCurrent = Just item }) cl
1052     actionOfCommand _ = Nothing
1053
1054     pipeRendered :: Bool -> [CommandArg] -> CommandAction
1055     pipeRendered ansi' args item = (\action -> actionOnRendered ansi' action item) $ \ls ->
1056         liftIO . void . runMaybeT $ do
1057             cmd <- case args of
1058                 [] -> maybe notSet
1059                     (\s -> if null s then notSet else return s) =<<
1060                     liftIO (lookupEnv "PAGER")
1061                     where
1062                     notSet = printErr "Please set $PAGER or give a command to run" >> mzero
1063                 (CommandArg _ cmd : _) -> return cmd
1064             lift . doRestricted . pipeToShellLazily cmd (historyEnv item) . T.encodeUtf8 $ T.unlines ls
1065
1066     setCurr :: HistoryItem -> ClientM ()
1067     setCurr i =
1068         let isJump = isNothing $ curr >>= pathItemByUri i . historyUri
1069         in do
1070             when isJump $ modify $ \s -> s { clientJumpBack = curr }
1071             modify $ \s -> s { clientCurrent = Just i }
1072
1073     doDefault :: HistoryItem -> ClientM ()
1074     doDefault item =
1075         maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction
1076
1077     goHistory :: HistoryItem -> ClientM ()
1078     goHistory item = do
1079         dropUriFromQueues uri
1080         showUri uri
1081         doDefault item
1082         setCurr item
1083         where uri = historyUri item
1084
1085     goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM ()
1086     goUri forceRequest origin uri = do
1087         dropUriFromQueues uri
1088         activeId <- gets $ isJust . (`idAtUri` uri) . clientActiveIdentities
1089         case curr >>= flip pathItemByUri uri of
1090             Just i' | not (activeId || forceRequest) -> goHistory i'
1091             _ -> doRequestUri uri $ \item -> do
1092                 doDefault item
1093                 liftIO $ slurpItem item
1094                 let updateParent i =
1095                         -- Lazily recursively update the links in the doubly linked list
1096                         let i' = i { historyParent = updateParent . updateChild i' <$> historyParent i }
1097                         in i'
1098                     updateChild i' i = i { historyChild = setChild <$> historyChild i }
1099                         where setChild c = c { childItem = i' }
1100                     glueOrigin (HistoryOrigin o l) = updateParent $ o { historyChild = Just $ HistoryChild item' l }
1101                     item' = item { historyParent = glueOrigin <$> origin }
1102                 setCurr item'
1103
1104     doRequestUri :: URI -> CommandAction -> ClientM ()
1105     doRequestUri uri0 action = doRequestUri' 0 uri0
1106         where
1107         doRequestUri' redirs uri
1108             | Just req <- requestOfUri uri = addToLog uri >> doRequest redirs req
1109             | otherwise = printErr $ "Bad URI: " ++ displayUri uri ++ (
1110                     let scheme = uriScheme uri
1111                     in if scheme /= "gemini" && isNothing (M.lookup scheme proxies)
1112                     then " : No proxy set for non-gemini scheme " ++ scheme ++ "; use \"browse\"?"
1113                     else "")
1114
1115         doRequest :: Int -> Request -> ClientM ()
1116         doRequest redirs _ | redirs > 5 =
1117             printErr "Too many redirections!"
1118         doRequest redirs req@(NetworkRequest _ uri) = do
1119             (mId, ais) <- liftIO . useActiveIdentity noConfirm ansi req =<< gets clientActiveIdentities
1120             modify $ \s -> s { clientActiveIdentities = ais }
1121             printInfo $ ">>> " ++ showUriFull ansi ais Nothing uri
1122             let respBuffSize = 2 ^ (15::Int) -- 32KB max cache for response stream
1123             liftIO (makeRequest requestContext mId respBuffSize verboseConnection req)
1124                 `bracket` either (\_ -> return ()) (liftIO . snd) $
1125                 either
1126                     (printErr . displayException)
1127                     (handleResponse . fst)
1128             where
1129             handleResponse :: Response -> ClientM ()
1130             handleResponse (Input isPass prompt) = do
1131                 let defaultPrompt = "[" ++ (if isPass then "PASSWORD" else "INPUT") ++ "]"
1132                 (liftIO . (join <$>) . promptInput $
1133                         (if null prompt then defaultPrompt else prompt) ++ " > ") >>= \case
1134                     Nothing -> return ()
1135                     Just query -> doRequestUri' redirs . setQuery ('?':escapeQuery query) $ uri
1136
1137             handleResponse (Success mimedData) = doAction req mimedData
1138
1139             handleResponse (Redirect isPerm to) = do
1140                 ais <- gets clientActiveIdentities
1141                 let uri' = to `relativeTo` uri
1142                     crossSite = uriRegName uri' /= uriRegName uri
1143                     crossScheme = uriScheme uri' /= uriScheme uri
1144                     [fromId,toId] = idAtUri ais <$> [uri,uri']
1145                     crossScope = isJust toId && fromId /= toId
1146                     warningStr = colour BoldRed
1147                 proceed <- (isJust <$>) . lift . runMaybeT $ do
1148                     when crossSite $ guard <=< (liftIO . promptYN False) $
1149                         warningStr "Follow cross-site redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
1150                     when crossScheme $ guard <=< (liftIO . promptYN False) $
1151                         warningStr "Follow cross-protocol redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
1152                     when crossScope $ guard <=< (liftIO . promptYN False) $
1153                         warningStr "Follow redirect with identity " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
1154                 when proceed $ do
1155                     when (isPerm && not ghost) . mapM_ (updateMark uri') . marksWithUri uri =<< gets clientMarks
1156                     doRequestUri' (redirs + 1) uri'
1157                 where updateMark uri' (mark,uriId) = do
1158                         conf <- confirm . liftIO . promptYN True $ "Update mark '" <> mark <> " to " <> show uri' <> " ?"
1159                         when conf . setMark mark $ uriId { uriIdUri = uri' }
1160             handleResponse (Failure code info) | 60 <= code && code <= 69 = void . runMaybeT $ do
1161                 identity <- do
1162                         liftIO . putStrLn $ (case code of
1163                             60 -> "Server requests identification"
1164                             _ -> "Server rejects provided identification certificate" ++
1165                                 (if code == 61 then " as unauthorised" else if code == 62 then " as invalid" else ""))
1166                             ++ if null info then "" else ": " ++ info
1167                         guard interactive
1168                         MaybeT . liftIO $ getIdentityRequesting ansi idsPath
1169                 lift $ do
1170                     addIdentity req identity
1171                     doRequest redirs req
1172
1173             handleResponse (Failure code info) =
1174                 printErr $ "Server returns failure: " ++ show code ++ " " ++ info
1175             handleResponse (MalformedResponse malformation) =
1176                 printErr $ "Malformed response from server: " ++ show malformation
1177
1178         doRequest redirs (LocalFileRequest path) | redirs > 0 = printErr "Ignoring redirect to local file."
1179             | otherwise = void . runMaybeT $ do
1180                 (path', mimedData) <- MaybeT . liftIO . doRestrictedAlt . RestrictedIO . warnIOErrAlt $ do
1181                     let detectExtension = case takeExtension path of
1182                             -- |certain crucial filetypes we can't rely on magic to detect:
1183                             s | s `elem` [".gmi", ".gem", ".gemini"] -> Just "text/gemini"
1184                             ".md" -> Just "text/markdown"
1185                             ".html" -> Just "text/html"
1186                             _ -> Nothing
1187 #ifdef MAGIC
1188                         detectPlain "text/plain" = fromMaybe "text/plain" detectExtension
1189                         detectPlain s = s
1190                     magic <- Magic.magicOpen [Magic.MagicMimeType]
1191                     Magic.magicLoadDefault magic
1192                     s <- detectPlain <$> Magic.magicFile magic path
1193 #else
1194                     let s = if "/" `isSuffixOf` path then "inode/directory"
1195                             else fromMaybe "application/octet-stream" detectExtension
1196 #endif
1197                     case MIME.parseMIMEType $ TS.pack s of
1198                         Nothing -> printErr ("Failed to parse mimetype string: " <> s) >> return Nothing
1199                         _ | s == "inode/directory" -> Just . (slashedPath,) . MimedData gemTextMimeType .
1200                             T.encodeUtf8 . T.unlines .
1201                             ((("=> " <>) . T.pack . escapePathString) <$>) . sort <$>
1202                                 getDirectoryContents path
1203                             where slashedPath | "/" `isSuffixOf` path = path
1204                                     | otherwise = path <> "/"
1205                         Just mimetype -> Just . (path,) . MimedData mimetype <$> BL.readFile path
1206                 lift $ doAction (LocalFileRequest path') mimedData
1207
1208         doAction req mimedData = do
1209             t0 <- liftIO timeCurrentP
1210             geminated <- geminate mimedData
1211             action $ HistoryItem req t0 mimedData geminated Nothing Nothing
1212             where
1213             -- |returns MimedData with lazy IO
1214             geminate :: MimedData -> ClientM MimedData
1215             geminate mimed =
1216                 let geminator = lookupGeminator $ showMimeType mimed
1217                 in liftIO . unsafeInterleaveIO $ applyGeminator geminator
1218                 where
1219                 lookupGeminator mimetype =
1220                     listToMaybe [ gem | (_, (regex, gem)) <- geminators
1221                         , isJust $ matchRegex regex mimetype ]
1222                 applyGeminator Nothing = return mimed
1223                 applyGeminator (Just cmd) =
1224                     printInfo ("| " <> cmd) >>
1225                     MimedData gemTextMimeType <$>
1226                         doRestrictedFilter (filterShell cmd [("URI", show $ requestUri req)]) (mimedBody mimed)
1227
1228         gemTextMimeType :: MIME.Type
1229         gemTextMimeType = MIME.Type (MIME.Text "gemini") []
1230
1231
1232     addIdentity :: Request -> Identity -> ClientM ()
1233     addIdentity req identity = do
1234         ais <- gets clientActiveIdentities >>= liftIO . insertIdentity req identity
1235         modify $ \s -> s {clientActiveIdentities = ais}
1236     endIdentityPrompted :: Request -> Identity -> ClientM ()
1237     endIdentityPrompted root ident = do
1238         conf <- confirm $ liftIO . promptYN False $ "Stop using " ++
1239             (if isTemporary ident then "temporary anonymous identity" else showIdentity ansi ident) ++
1240             " at " ++ displayUri (requestUri root) ++ "?"
1241         when conf . modify $ \s ->
1242                 s { clientActiveIdentities = deleteIdentity root $ clientActiveIdentities s }
1243
1244     extractLinksMimed :: MimedData -> [Link]
1245     extractLinksMimed (MimedData (MIME.Type (MIME.Text "gemini") _) body) =
1246         extractLinks . parseGemini $ T.decodeUtf8With T.lenientDecode body
1247     extractLinksMimed _ = []
1248
1249     renderMimed :: Bool -> URI -> ActiveIdentities -> MimedData -> IO (Either String [T.Text])
1250     renderMimed ansi' uri ais (MimedData mime body) = case MIME.mimeType mime of
1251         MIME.Text textType -> do
1252             let extractCharsetParam (MIME.MIMEParam "charset" v) = Just v
1253                 extractCharsetParam _                            = Nothing
1254                 charset = TS.unpack . fromMaybe "utf-8" . msum . map extractCharsetParam $ MIME.mimeParams mime
1255                 isUtf8 = map toLower charset `elem` ["utf-8", "utf8"]
1256 #ifdef ICONV
1257                 reencoder = if isUtf8 then id else
1258                     convert charset "UTF-8"
1259 #else
1260                 reencoder = id
1261             unless isUtf8 . printErr $
1262                 "Warning: Treating unsupported charset " ++ show charset ++ " as utf-8"
1263 #endif
1264             (_,width) <- getTermSize
1265             let pageWidth = if interactive
1266                 then min maxWrapWidth (width - 4)
1267                 else maxWrapWidth
1268             let bodyText = T.decodeUtf8With T.lenientDecode $ reencoder body
1269                 applyFilter :: [T.Text] -> IO [T.Text]
1270                 applyFilter = case renderFilter of
1271                     Nothing -> return
1272                     Just cmd -> (T.lines . T.decodeUtf8With T.lenientDecode <$>) .
1273                         doRestrictedFilter (filterShell cmd []) . BL.concat . (appendNewline . T.encodeUtf8 <$>)
1274                         where appendNewline = (`BL.snoc` 10)
1275             (Right <$>) . applyFilter . (sanitiseNonCSI <$>) $ case textType of
1276                     "gemini" ->
1277                         let opts = GemRenderOpts ansi' preOpt pageWidth linkDescFirst
1278                         in printGemDoc opts (showUriRefFull ansi' ais uri) $ parseGemini bodyText
1279                     _ -> T.stripEnd <$> T.lines bodyText
1280         mimeType ->
1281             return . Left $ "No geminator for " ++ TS.unpack (MIME.showMIMEType mimeType) ++ " configured. Try \"save\", \"view\", \"!\", or \"|\"?"