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