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