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