diohsc.hs

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