diohsc.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE CPP               #-}
  12 {-# LANGUAGE FlexibleContexts  #-}
  13 {-# LANGUAGE LambdaCase        #-}
  14 {-# LANGUAGE OverloadedStrings #-}
  15 {-# LANGUAGE TupleSections     #-}
  16
  17 module Main where
  18
  19 import           Control.Applicative          (Alternative, empty)
  20 import           Control.Monad.Catch
  21 import           Control.Monad.State
  22 import           Control.Monad.Trans.Maybe    (MaybeT (..), runMaybeT)
  23 import           Data.Bifunctor               (second)
  24 import           Data.Char                    (isAlpha, isUpper, toLower)
  25 import           Data.Hash                    (Hash, hash)
  26 import           Data.IORef                   (modifyIORef, newIORef, readIORef)
  27 import           Data.List                    (find, intercalate, isPrefixOf,
  28                                                isSuffixOf, sort, stripPrefix)
  29 import           Data.Maybe
  30 import           Safe
  31 import           System.Directory
  32 import           System.Environment
  33 import           System.Exit
  34 import           System.FilePath
  35 import           System.IO
  36 import           System.IO.Unsafe             (unsafeInterleaveIO)
  37 import           Text.Regex                   (Regex, matchRegex,
  38                                                mkRegexWithOpts)
  39 import           Time.System                  (timeCurrentP)
  40 import           Time.Types                   (ElapsedP)
  41
  42 import qualified Data.ByteString.Lazy         as BL
  43
  44 import qualified Codec.MIME.Parse             as MIME
  45 import qualified Codec.MIME.Type              as MIME
  46 import qualified Data.Map                     as M
  47 import qualified Data.Set                     as S
  48 import qualified Data.Text                    as TS
  49 import qualified Data.Text.Encoding.Error     as T
  50 import qualified Data.Text.Lazy               as T
  51 import qualified Data.Text.Lazy.Encoding      as T
  52 import qualified Data.Text.Lazy.IO            as T
  53 import qualified System.Console.Haskeline     as HL
  54 import qualified System.Console.Terminal.Size as Size
  55
  56 import           ActiveIdentities
  57 import           Alias
  58 import           ANSIColour
  59 import qualified BStack
  60 import           ClientCert                   (KeyType (..))
  61 import           Command
  62 import           CommandLine
  63 import           GeminiProtocol
  64 import           Identity
  65 import           Marks
  66 import           MetaString
  67 import           Mundanities
  68 import           Opts
  69 import           Pager
  70 import           Prompt                       hiding (promptYN)
  71 import qualified Prompt
  72 import           Request
  73 import qualified RunExternal
  74 import           RunExternal                  hiding (runRestrictedIO)
  75 import           Slurp
  76 import           TextGemini
  77 import           URI
  78 import           Util
  79 import           Version
  80
  81 #ifndef WINDOWS
  82 import           System.Posix.Files           (ownerModes, setFileMode)
  83 #endif
  84
  85 #ifdef ICONV
  86 import           Codec.Text.IConv             (convert)
  87 #endif
  88
  89 #ifdef MAGIC
  90 import qualified Magic
  91 #endif
  92
  93 -- |Immutable options set at startup
  94 data ClientOptions = ClientOptions
  95     { cOptUserDataDir    :: FilePath
  96     , cOptInteractive    :: Bool
  97     , cOptAnsi           :: Bool
  98     , cOptGhost          :: Bool
  99     , cOptRestrictedMode :: Bool
 100     , cOptRequestContext :: RequestContext
 101     , cOptLogH           :: Maybe Handle
 102     }
 103
 104 data HistoryChild = HistoryChild
 105     { childItem :: HistoryItem
 106     , childLink :: Maybe Int
 107     }
 108
 109 data HistoryOrigin = HistoryOrigin
 110     { originItem :: HistoryItem
 111     , originLink :: Maybe Int
 112     }
 113
 114 data HistoryItem = HistoryItem
 115     { historyRequest            :: Request
 116     , historyRequestTime        :: ElapsedP
 117     , historyMimedData          :: MimedData
 118     , historyGeminatedMimedData :: MimedData -- ^generated with lazy IO
 119     , historyParent             :: Maybe HistoryItem
 120     , historyChild              :: Maybe HistoryChild
 121     }
 122
 123 historyUri :: HistoryItem -> URI
 124 historyUri = requestUri . historyRequest
 125
 126 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                 mapMaybe 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 False 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 -> Bool -> 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         blockGo
 441     = \(CommandLine mt mcas) -> case mcas of
 442         Just (c,args) | Just (Alias _ (CommandLine mt' mcas')) <- lookupAlias c aliases ->
 443             let mcas'' = (, drop 1 args) . commandArgArg <$> headMay args
 444                 appendCArgs (c',as') = (c', (appendTail <$> as') ++ args)
 445                     where
 446                     appendTail arg@(CommandArg a' t') = case args of
 447                         []                   -> arg
 448                         (CommandArg _ t : _) -> CommandArg a' $ t' <> " " <> t
 449             in handleCommandLine' (mt' `mplus` mt) $
 450                 (appendCArgs <$> mcas') `mplus` mcas''
 451         _ -> handleCommandLine' mt mcas
 452
 453     where
 454
 455     -- Remark: we handle haskell's "configurations problem" by having the below all within the scope
 456     -- of the ClientOptions parameter. This is nicer to my mind than the heavier approaches of
 457     -- simulating global variables or threading a Reader monad throughout. The downside is that this
 458     -- module can't be split as much as it ought to be.
 459     -- Similar remarks go for `GeminiProtocol.makeRequest`.
 460
 461     onRestriction :: IO ()
 462     onRestriction = printErr "This is not allowed in restricted mode."
 463
 464     doRestricted :: Monoid a => RestrictedIO a -> IO a
 465     doRestricted m | restrictedMode = onRestriction >> return mempty
 466         | otherwise = RunExternal.runRestrictedIO m
 467
 468     doRestrictedAlt :: Alternative f => RestrictedIO (f a) -> IO (f a)
 469     doRestrictedAlt m | restrictedMode = onRestriction >> return empty
 470         | otherwise = RunExternal.runRestrictedIO m
 471
 472     doRestrictedFilter :: (a -> RestrictedIO a) -> (a -> IO a)
 473     doRestrictedFilter f | restrictedMode = \a -> do
 474             onRestriction
 475             return a
 476         | otherwise = RunExternal.runRestrictedIO . f
 477
 478     printInfo :: MonadIO m => String -> m ()
 479     printInfo = printInfoOpt ansi
 480     printErr :: MonadIO m => String -> m ()
 481     printErr = printErrOpt ansi
 482
 483     printIOErr :: IOError -> IO ()
 484     printIOErr = printErr . show
 485
 486     noConfirm :: Bool
 487     noConfirm = confNoConfirm || not interactive
 488
 489     confirm :: Applicative m => m Bool -> m Bool
 490     confirm | noConfirm = const $ pure True
 491         | otherwise = id
 492
 493     promptYN = Prompt.promptYN interactive
 494
 495     colour :: MetaString a => Colour -> a -> a
 496     colour = applyIf ansi . withColourStr
 497     bold :: MetaString a => a -> a
 498     bold = applyIf ansi withBoldStr
 499
 500     isVisited :: URI -> Bool
 501     isVisited uri = S.member (hash $ show uri) visited
 502
 503     requestOfUri = requestOfProxiesAndUri proxies
 504
 505     idAtUri :: ActiveIdentities -> URI -> Maybe Identity
 506     idAtUri ais uri = findIdentity ais =<< requestOfUri uri
 507
 508     showUriRefFull :: MetaString a => Bool -> ActiveIdentities -> URI -> URIRef -> a
 509     showUriRefFull ansi' ais base ref = showUriFull ansi' ais (Just base) $ relativeTo ref base
 510
 511     showUriFull :: MetaString a => Bool -> ActiveIdentities -> Maybe URI -> URI -> a
 512     showUriFull ansi' ais base uri =
 513         let scheme = uriScheme uri
 514             handled = scheme `elem` ["gemini","file"] || M.member scheme proxies
 515             inHistory = isJust $ curr >>= flip pathItemByUri uri
 516             activeId = isJust $ idAtUri ais uri
 517             col = if inHistory && not activeId then BoldBlue else case (isVisited uri,handled) of
 518                 (True,True)   -> Yellow
 519                 (False,True)  -> BoldYellow
 520                 (True,False)  -> Red
 521                 (False,False) -> BoldRed
 522             s = case base of
 523                 Nothing -> show uri
 524                 Just b  -> show $ relativeFrom uri b
 525         in fromString (applyIf ansi' (withColourStr col) s) <> case idAtUri ais uri of
 526             Nothing    -> ""
 527             Just ident -> showIdentity ansi' ident
 528
 529     displayUri :: MetaString a => URI -> a
 530     displayUri = colour Yellow . fromString . show
 531
 532     showUri :: URI -> ClientM ()
 533     showUri uri = do
 534         ais <- gets clientActiveIdentities
 535         liftIO . putStrLn $ showUriFull ansi ais Nothing uri
 536
 537     addToLog :: URI -> ClientM ()
 538     addToLog uri = do
 539         let t = T.pack $ show uri
 540         modify $ \s -> s
 541             { clientLog = BStack.push maxLogLen t $ clientLog s
 542             , clientVisited = S.insert (hash $ show uri) $ clientVisited s }
 543         unless ghost . liftIO $ maybe (return ()) (ignoreIOErr . (`T.hPutStrLn` t)) logH
 544
 545     loggedUris = catMaybes $ (parseAbsoluteUri . escapeIRI . T.unpack <$>) $ BStack.toList cLog
 546
 547     expand :: String -> String
 548     expand = expandHelp ansi (fst <$> aliases) userDataDir
 549
 550     idsPath = userDataDir </> "identities"
 551     savesDir = userDataDir </> "saves"
 552     marksDir = userDataDir </> "marks"
 553
 554     setMark :: String -> URIWithIdName -> ClientM ()
 555     setMark mark uriId | markNameValid mark = do
 556         modify $ \s -> s { clientMarks = insertMark mark uriId $ clientMarks s }
 557         unless (mark `elem` tempMarks) . liftIO .
 558             handle printIOErr $ saveMark marksDir mark uriId
 559     setMark mark _ = printErr $ "Invalid mark name " ++ mark
 560
 561     promptInput = if ghost then promptLine else promptLineWithHistoryFile inputHistPath
 562         where inputHistPath = userDataDir </> "inputHistory"
 563
 564     handleCommandLine' :: Maybe PTarget -> Maybe (String, [CommandArg]) -> ClientM ()
 565     handleCommandLine' mt mcas = void . runMaybeT $ do
 566         ts <- case mt of
 567             Nothing -> return []
 568             Just pt -> either ((>> mzero) . printErr)
 569                 (\ts -> mapM_ addTargetId ts >> return ts) $
 570                 resolveTarget pt
 571         case mcas of
 572             Nothing -> lift $ handleBareTargets ts
 573             Just (s,as) -> do
 574                 c' <- maybe (printErr (unknownCommand s) >> mzero)
 575                     return $ normaliseCommand s
 576                 lift $ handleCommand ts (c',as)
 577         where
 578         unknownCommand s = "Unknown command \"" <> s <> "\". Type \"help\" for help."
 579         addTargetId :: Target -> MaybeT ClientM ()
 580         addTargetId (TargetIdUri idName uri) =
 581             liftIO (loadIdentity idsPath idName) >>= (\case
 582                 (Nothing, _) -> printErr ("Bad URI: " ++ show uri) >> mzero
 583                 (_, Nothing) -> printErr ("Unknown identity: " ++ showIdentityName ansi idName) >> mzero
 584                 (Just req, Just ident) -> lift $ addIdentity req ident) . (requestOfUri uri,)
 585         addTargetId _ = return ()
 586
 587     resolveTarget :: PTarget -> Either String [Target]
 588     resolveTarget PTargetCurr =
 589         (:[]) . TargetHistory <$> maybeToEither "No current location" curr
 590
 591     resolveTarget PTargetJumpBack =
 592         (:[]) . TargetHistory <$> maybeToEither "'' mark not set" jumpBack
 593
 594     resolveTarget (PTargetMark s)
 595         | Just n <- readMay s =
 596             (:[]) . TargetHistory <$> maybeToEither ("Mark not set: " <> s) (M.lookup n sessionMarks)
 597         | otherwise =
 598             (:[]) . targetOfMark <$> maybeToEither ("Unknown mark: " <> s) (lookupMark s marks)
 599             where
 600             targetOfMark (URIWithIdName uri Nothing) = TargetUri uri
 601             targetOfMark (URIWithIdName uri (Just idName)) = TargetIdUri idName uri
 602
 603     resolveTarget (PTargetLog specs) =
 604         (TargetUri <$>) <$> resolveElemsSpecs "log entry" (matchPatternOn show) loggedUris specs
 605
 606     resolveTarget (PTargetQueue qname specs) =
 607         (queueTarget <$>) <$> resolveElemsSpecs "queue item"
 608             (matchPatternOn $ show . queueUri) queue specs
 609         where
 610         queue = M.findWithDefault [] qname queues
 611         queueTarget (QueueURI Nothing uri)  = TargetUri uri
 612         queueTarget (QueueURI (Just o) uri) = TargetFrom o uri
 613         queueTarget (QueueHistory item)     = TargetHistory item
 614
 615     resolveTarget (PTargetRoot base) =
 616         (rootOf <$>) <$> resolveTarget base
 617         where
 618         rootOf :: Target -> Target
 619         rootOf (TargetHistory item)                  = rootOfItem item
 620         rootOf (TargetFrom (HistoryOrigin item _) _) = rootOfItem item
 621         rootOf t                                     = t
 622         rootOfItem item = TargetHistory . lastDef item $ historyAncestors item
 623
 624     resolveTarget (PTargetAncestors base specs) =
 625         concat <$> (mapM resolveAncestors =<< resolveTarget base)
 626         where
 627         resolveAncestors :: Target -> Either String [Target]
 628         resolveAncestors (TargetHistory item) =
 629             resolveAncestors' $ historyAncestors item
 630         resolveAncestors (TargetFrom (HistoryOrigin item _) _) =
 631             resolveAncestors' $ item : historyAncestors item
 632         resolveAncestors _ = Left "No history"
 633         resolveAncestors' hist = (TargetHistory <$>) <$>
 634             resolveElemsSpecs "ancestor" (matchPatternOn $ show . historyUri)
 635                 hist specs
 636
 637     resolveTarget (PTargetDescendants base specs) =
 638         concat <$> (mapM resolveDescendants =<< resolveTarget base)
 639         where
 640         resolveDescendants :: Target -> Either String [Target]
 641         resolveDescendants (TargetHistory item) = (TargetHistory <$>) <$>
 642             resolveElemsSpecs "descendant" (matchPatternOn $ show . historyUri)
 643                 (historyDescendants item) specs
 644         resolveDescendants _ = Left "No history"
 645
 646     resolveTarget (PTargetChild increasing noVisited base specs) =
 647         concat <$> (mapM resolveChild =<< resolveTarget base)
 648         where
 649         resolveChild (TargetHistory item) =
 650             let itemLinks = extractLinksMimed $ historyGeminatedMimedData item
 651                 b = case historyChild item of
 652                     Just (HistoryChild _ (Just b')) -> b'
 653                     _ | increasing                  -> -1
 654                     _                               -> length itemLinks
 655                 slice | increasing = zip [b+1..] $ drop (b+1) itemLinks
 656                     | otherwise = zip (reverse [0..b-1]) . reverse $ take b itemLinks
 657                 linkUnvisited (_,l) = not . isVisited $ linkUri l `relativeTo` historyUri item
 658                 slice' = applyIf noVisited (filter linkUnvisited) slice
 659             in resolveLinkSpecs False item slice' specs
 660         resolveChild _ = Left "No known links"
 661
 662     resolveTarget (PTargetLinks noVisited base specs) =
 663         concat <$> (mapM resolveLinks =<< resolveTarget base)
 664         where
 665         resolveLinks (TargetHistory item) =
 666             let itemLinks = extractLinksMimed $ historyGeminatedMimedData item
 667             in resolveLinkSpecs noVisited item (zip [0..] itemLinks) specs
 668         resolveLinks _ = Left "No known links"
 669
 670     resolveTarget (PTargetRef base s) =
 671         let makeRel r | base == PTargetCurr = r
 672             makeRel r@('/':_) = '.':r
 673             makeRel r = r
 674         in case parseUriReference . escapeIRI . escapeQueryPart $ makeRel s of
 675             Nothing -> Left $ "Failed to parse relative URI: " <> s
 676             Just ref -> map relTarget <$> resolveTarget base
 677                 where
 678                 relTarget (TargetHistory item) = TargetFrom (HistoryOrigin item Nothing) $
 679                     ref `relativeTo` historyUri item
 680                 relTarget (TargetFrom o uri) = TargetFrom o $ relativeTo ref uri
 681                 relTarget t = TargetUri . relativeTo ref $ targetUri t
 682
 683     resolveTarget (PTargetAbs s) = case parseUriAsAbsolute . escapeIRI $ escapeQueryPart s of
 684         Nothing  -> Left $ "Failed to parse URI: " <> s
 685         Just uri -> return [TargetUri uri]
 686
 687     resolveLinkSpecs :: Bool -> HistoryItem -> [(Int,Link)] -> ElemsSpecs -> Either String [Target]
 688     resolveLinkSpecs purgeVisited item slice specs =
 689         let isMatch s (_,l) = matchPattern s (show $ linkUri l) ||
 690                 matchPattern s (T.unpack $ linkDescription l)
 691             linkTarg (n,l) =
 692                 let uri = linkUri l `relativeTo` historyUri item
 693                 in if purgeVisited && isVisited uri then Nothing
 694                     else Just $ TargetFrom (HistoryOrigin item $ Just n) uri
 695         in resolveElemsSpecs "link" isMatch slice specs >>= (\case
 696             []    -> Left "No such link"
 697             targs -> return targs) . mapMaybe linkTarg
 698
 699     matchPattern :: String -> String -> Bool
 700     matchPattern patt =
 701         let regex = mkRegexWithOpts patt True (any isUpper patt)
 702         in isJust . matchRegex regex
 703
 704     matchPatternOn :: (a -> String) -> String -> a -> Bool
 705     matchPatternOn f patt = matchPattern patt . f
 706
 707     doPage :: [T.Text] -> ClientM ()
 708     doPage ls
 709         | interactive = do
 710             (height,width) <- liftIO getTermSize
 711             let pageWidth = min maxWrapWidth (width - 4)
 712                 perPage = height - min 3 (height `div` 4)
 713                 doCmd str = get >>= \s -> doSubCommand s True str
 714             printLinesPaged pageWidth width perPage doCmd ls
 715         | otherwise = liftIO $ mapM_ T.putStrLn ls
 716
 717     parseQueueSpec :: [CommandArg] -> Maybe (String, Maybe Int)
 718     parseQueueSpec [] = Just ("", Nothing)
 719     parseQueueSpec [CommandArg a _] | Just n <- readMay a = Just ("", Just n)
 720     parseQueueSpec (CommandArg a _:as) | not (null a), all isAlpha a
 721         , Just mn <- case as of
 722             []                                       -> Just Nothing
 723             [CommandArg a' _] | Just n <- readMay a' -> Just (Just n)
 724             _                                        -> Nothing
 725         = Just (a, mn)
 726     parseQueueSpec _ = Nothing
 727
 728     handleBareTargets :: [Target] -> ClientM ()
 729     handleBareTargets [] = return ()
 730     handleBareTargets (_:_:_) =
 731         printErr "Can only go to one place at a time. Try \"show\" or \"page\"?"
 732     handleBareTargets [TargetHistory item] = goHistory item
 733     handleBareTargets [TargetFrom origin uri] = goUri False (Just origin) uri
 734     handleBareTargets [t] = goUri False Nothing $ targetUri t
 735
 736
 737     handleCommand :: [Target] -> (String, [CommandArg]) -> ClientM ()
 738     handleCommand _ (c,_) | restrictedMode && notElem c (commands True) =
 739         printErr "Command disabled in restricted mode"
 740     handleCommand [] ("help", args) = case args of
 741         []                 -> doPage . map (T.pack . expand) $ helpText
 742         CommandArg s _ : _ -> doPage . map (T.pack . expand) $ helpOn s
 743     handleCommand [] ("commands",_) = doPage $ T.pack . expand <$> commandHelpText
 744         where
 745         commandHelpText = ["Aliases:"] ++ (showAlias <$> aliases) ++
 746             ["","Commands:"] ++ (('{' :) . (<> "}") <$> commands False)
 747         showAlias (a, Alias s _) = "{" <> a <> "}: " <> s
 748
 749     handleCommand [] ("mark", []) =
 750         let ms = M.toAscList marks
 751             markLine (m, uriId) = let m' = showMinPrefix ansi (fst <$> ms) m
 752                 in T.pack $ "'" <> m' <>
 753                     replicate (max 1 $ 16 - visibleLength (T.pack m')) ' ' <>
 754                     showUriWithId uriId
 755         in doPage $ markLine <$> ms
 756     handleCommand [] ("inventory",_) = do
 757         ais <- gets clientActiveIdentities
 758         let showNumberedUri :: Bool -> T.Text -> (Int,URI) -> T.Text
 759             showNumberedUri iter s (n,uri) = s <>
 760                 (if iter && n == 1 then " "
 761                     else if iter && n == 2 then T.takeEnd 1 s
 762                     else T.pack (show n)) <>
 763                 " " <> showUriFull ansi ais Nothing uri
 764             showIteratedItem s (n,item) = showNumberedUri True s (n, historyUri item)
 765             showNumberedItem s (n,item) = showNumberedUri False s (n, historyUri item)
 766             showIteratedQueueItem s (n, QueueURI _ uri) =
 767                 showNumberedUri True s (n, uri)
 768             showIteratedQueueItem s (n, QueueHistory item) =
 769                 showNumberedUri True s (n, historyUri item) <> " {fetched}"
 770             showJumpBack :: [T.Text]
 771             showJumpBack = maybeToList $ ("'' " <>) . showUriFull ansi ais Nothing . historyUri <$> jumpBack
 772         doPage . intercalate [""] . filter (not . null) $
 773             showJumpBack :
 774             [ showIteratedQueueItem (T.pack $ qname <> "~") <$> zip [1..] queue
 775                 | (qname, queue) <- M.toList queues ]
 776             ++ [ showNumberedItem "'" <$> M.toAscList sessionMarks
 777             , (showIteratedItem "<" <$> zip [1..] (maybe [] (initSafe . historyAncestors) curr))
 778             ++ (("@  " <>) . showUriFull ansi ais Nothing . historyUri <$>
 779                 maybeToList (curr >>= lastMay . historyAncestors))
 780             , showIteratedItem ">" <$> zip [1..] (maybe [] historyDescendants curr)
 781             ]
 782     handleCommand [] ("log",_) =
 783         let showLog (n,t) = "$" <> T.pack (show n) <> " " <> colour Yellow t
 784         in doPage $ showLog <$> zip [(1::Int)..] (BStack.toList cLog)
 785     handleCommand [] ("alias", CommandArg a _ : CommandArg _ str : _) = void . runMaybeT $ do
 786         c <- either ((>>mzero) . printErr) return $ parseCommand a
 787         when (c /= a) $ printErr ("Bad alias: " <> a) >> mzero
 788         cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
 789         modify $ \s ->
 790                 s { clientAliases = insertAlias a (Alias str cl) . deleteAlias a $ clientAliases s }
 791     handleCommand [] ("alias", [CommandArg a _]) =
 792         modify $ \s -> s { clientAliases = deleteAlias a $ clientAliases s }
 793     handleCommand [] ("set", []) = liftIO $ do
 794         let (c,args) = defaultAction
 795         putStrLn $ expand "{default_action}: " <> c <>
 796             maybe "" ((" "<>) . commandArgLiteralTail) (headMay args)
 797         putStrLn $ expand "{proxies}:"
 798         printMap showHost $ M.toAscList proxies
 799         putStrLn $ expand "{geminators}:"
 800         printMap id $ second snd <$> geminators
 801         putStrLn $ expand "{render_filter}: " <> fromMaybe "" renderFilter
 802         putStrLn $ expand "{pre_display}: " <> showPreOpt preOpt
 803         putStrLn $ expand "{link_desc_first}: " <> show linkDescFirst
 804         putStrLn $ expand "{log_length}: " <> show maxLogLen
 805         putStrLn $ expand "{max_wrap_width}: " <> show maxWrapWidth
 806         putStrLn $ expand "{no_confirm}: " <> show noConfirm
 807         putStrLn $ expand "{verbose_connection}: " <> show verboseConnection
 808         where
 809             printMap :: (a -> String) -> [(String,a)] -> IO ()
 810             printMap f as = mapM_ putStrLn $
 811                 (\(k,e) -> "  " <> k <> " " <> f e) <$> as
 812     handleCommand [] ("set", CommandArg opt _ : val)
 813         | opt `isPrefixOf` "default_action" = case val of
 814             (CommandArg cmd _ : args) -> case actionOfCommand (cmd,args) of
 815                 Just _ -> modifyCConf $ \c -> c { clientConfDefaultAction = (cmd,args) }
 816                 Nothing -> printErr "Invalid action"
 817             _ -> printErr "Require value for option."
 818         | opt `isPrefixOf` "proxies" || opt `isPrefixOf` "proxy" = case val of
 819             (CommandArg scheme _ : val') ->
 820                 let f = maybe (M.delete scheme) (M.insert scheme) $
 821                         parseHost . commandArgLiteralTail =<< headMay val'
 822                 in modifyCConf $ \c -> c { clientConfProxies = f $ clientConfProxies c }
 823                     -- if only I'd allowed myself to use lenses, eh?
 824             [] -> printErr "Require mimetype to set geminator for."
 825         | opt `isPrefixOf` "geminators" = case val of
 826             (CommandArg patt _ : val') ->
 827                 let f = maybe (filter $ (/= patt) . fst)
 828                         (\v -> (++ [(patt, (mkRegexWithOpts patt True True,
 829                             commandArgLiteralTail v))])) $
 830                         headMay val'
 831                 in modifyCConf $ \c -> c { clientConfGeminators = f $ clientConfGeminators c }
 832             [] -> printErr "Require mimetype to set geminator for."
 833         | opt `isPrefixOf` "render_filter" =
 834             modifyCConf $ \c -> c { clientConfRenderFilter =
 835                 commandArgLiteralTail <$> headMay val }
 836         | opt `isPrefixOf` "pre_display" = case val of
 837             [CommandArg s _] | map toLower s `isPrefixOf` "both" ->
 838                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptBoth }
 839             [CommandArg s _] | map toLower s `isPrefixOf` "pre" ->
 840                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptPre }
 841             [CommandArg s _] | map toLower s `isPrefixOf` "alt" ->
 842                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptAlt }
 843             _ -> printErr "Require \"both\" or \"pre\" or \"alt\" for pre_display"
 844         | opt `isPrefixOf` "link_desc_first" = case val of
 845             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 846                 modifyCConf $ \c -> c { clientConfLinkDescFirst = True }
 847             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 848                 modifyCConf $ \c -> c { clientConfLinkDescFirst = False }
 849             _ -> printErr "Require \"true\" or \"false\" as value for link_desc_first"
 850         | opt `isPrefixOf` "log_length" = case val of
 851             [CommandArg s _] | Just n <- readMay s, n >= 0 -> do
 852                 modifyCConf $ \c -> c { clientConfMaxLogLen = n }
 853                 modify $ \st -> st { clientLog = BStack.truncate n $ clientLog st }
 854             _ -> printErr "Require non-negative integer value for log_length"
 855         | opt `isPrefixOf` "max_wrap_width" = case val of
 856             [CommandArg s _] | Just n <- readMay s, n > 0 ->
 857                 modifyCConf $ \c -> c { clientConfMaxWrapWidth = n }
 858             _ -> printErr "Require positive integer value for max_wrap_width"
 859         | opt `isPrefixOf` "no_confirm" = case val of
 860             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 861                 modifyCConf $ \c -> c { clientConfNoConfirm = True }
 862             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 863                 modifyCConf $ \c -> c { clientConfNoConfirm = False }
 864             _ -> printErr "Require \"true\" or \"false\" as value for no_confirm"
 865         | opt `isPrefixOf` "verbose_connection" = case val of
 866             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 867                 modifyCConf $ \c -> c { clientConfVerboseConnection = True }
 868             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 869                 modifyCConf $ \c -> c { clientConfVerboseConnection = False }
 870             _ -> printErr "Require \"true\" or \"false\" as value for verbose_connection"
 871         | otherwise = printErr $ "No such option \"" <> opt <> "\"."
 872     handleCommand [] cargs =
 873         case curr of
 874             Just item -> handleCommand [TargetHistory item] cargs
 875             Nothing -> printErr "No current location. Enter an URI, or type \"help\"."
 876
 877     handleCommand ts ("add", args) = case parseQueueSpec args of
 878         Nothing          -> printErr "Bad arguments to 'add'."
 879         Just (qname, mn) -> enqueue qname mn $ targetQueueItem <$> ts
 880
 881     handleCommand ts ("fetch", args) = case parseQueueSpec args of
 882         Nothing -> printErr "Bad arguments to 'fetch."
 883         Just (qname, mn) -> do
 884             -- XXX: we have to use an IORef to store the items, since
 885             -- CommandAction doesn't allow a return value.
 886             lRef <- liftIO $ newIORef []
 887             let add item = liftIO $ slurpItem item >> modifyIORef lRef (item:)
 888             forM_ ts $ \t -> case t of
 889                 TargetHistory item -> add item
 890                 _ -> dropUriFromQueues uri >> doRequestUri uri add
 891                     where uri = targetUri t
 892             l <- liftIO $ reverse <$> readIORef lRef
 893             enqueue qname mn $ QueueHistory <$> l
 894
 895     handleCommand ts cargs =
 896         mapM_ handleTargetCommand ts
 897         where
 898         handleTargetCommand (TargetHistory item) | Just action <- actionOfCommand cargs =
 899             action item
 900         handleTargetCommand t | Just action <- actionOfCommand cargs =
 901             let uri = targetUri t
 902             in dropUriFromQueues uri >> doRequestUri uri action
 903         handleTargetCommand (TargetHistory item) | ("repeat",_) <- cargs =
 904             goUri True (recreateOrigin <$> historyParent item) $ historyUri item
 905         handleTargetCommand (TargetHistory item) | ("repl",_) <- cargs =
 906             repl (recreateOrigin <$> historyParent item) $ historyUri item
 907         handleTargetCommand (TargetHistory item) =
 908             handleUriCommand (historyUri item) cargs
 909         handleTargetCommand t =
 910             handleUriCommand (targetUri t) cargs
 911
 912         recreateOrigin :: HistoryItem -> HistoryOrigin
 913         recreateOrigin parent = HistoryOrigin parent $ childLink =<< historyChild parent
 914
 915         handleUriCommand uri ("delete",[]) = dropUriFromQueue "" uri
 916         handleUriCommand uri ("delete",CommandArg qname _ : _) = dropUriFromQueue qname uri
 917         handleUriCommand uri ("repeat",_) = goUri True Nothing uri
 918         handleUriCommand uri ("uri",_) = showUri uri
 919         handleUriCommand uri ("mark", CommandArg mark _ : _)
 920             | Just _ <- readMay mark :: Maybe Int = error "Bad mark for uri"
 921             | otherwise = do
 922             ais <- gets clientActiveIdentities
 923             let mIdName = case findIdentity ais =<< requestOfUri uri of
 924                     Just ident | not $ isTemporary ident -> Just $ identityName ident
 925                     _ -> Nothing
 926             setMark mark $ URIWithIdName uri mIdName
 927         handleUriCommand uri ("identify", args) = case requestOfUri uri of
 928             Nothing -> printErr "Bad URI"
 929             Just req -> gets ((`findIdentityRoot` req) . clientActiveIdentities) >>= \case
 930                 Just (root,(ident,_)) | null args -> endIdentityPrompted root ident
 931                 _ -> void . runMaybeT $ do
 932                     ident <- MaybeT . liftIO $ case args of
 933                         CommandArg idName _ : args' ->
 934                             let tp = case args' of
 935                                     CommandArg ('e':'d':_) _ : _ -> KeyEd25519
 936                                     _                            -> KeyRSA
 937                             in getIdentity interactive ansi idsPath tp idName
 938                         [] -> if interactive
 939                             then getIdentityRequesting ansi idsPath
 940                             else getIdentity interactive ansi idsPath KeyRSA ""
 941                     lift $ addIdentity req ident
 942         handleUriCommand uri ("browse", args) = do
 943             ais <- gets clientActiveIdentities
 944             let envir = maybe [] (identityEnvironment idsPath) .
 945                     idAtUri ais . setSchemeDefault $ uri
 946             void . liftIO . runMaybeT $ do
 947                 cmd <- case args of
 948                     [] -> maybe notSet
 949                         (\s -> if null s then notSet else return $ parseBrowser s) =<<
 950                             lift (lookupEnv "BROWSER")
 951                         where
 952                         notSet = printErr "Please set $BROWSER or give a command to run" >> mzero
 953                         -- |based on specification for $BROWSER in 'man 1 man'
 954                         parseBrowser :: String -> String
 955                         parseBrowser = subPercentOrAppend (show uri) . takeWhile (/=':')
 956                     (CommandArg _ c : _) -> return $ subPercentOrAppend (show uri) c
 957                 lift $ confirm (confirmShell "Run" cmd) >>? doRestricted $ void (runShellCmd cmd envir)
 958         handleUriCommand uri ("repl",_) = repl Nothing uri
 959         handleUriCommand uri ("query", CommandArg _ str : _) =
 960                     goUri True Nothing . setQuery ('?':escapeQuery str) $ uri
 961         handleUriCommand uri ("log",_) = addToLog uri >> dropUriFromQueues uri
 962
 963         handleUriCommand _ (c,_) = printErr $ "Bad arguments to command " <> c
 964
 965         repl :: Maybe HistoryOrigin -> URI -> ClientM ()
 966         repl origin uri = repl' where
 967             repl' = liftIO (join <$> promptInput ">> ") >>= \case
 968                 Nothing -> return ()
 969                 Just query -> do
 970                     goUri True origin . setQuery ('?':escapeQuery query) $ uri
 971                     repl'
 972
 973     slurpItem :: HistoryItem -> IO ()
 974     slurpItem item = slurpNoisily (historyRequestTime item) . mimedBody $ historyMimedData item
 975
 976     actionOnRendered :: Bool -> ([T.Text] -> ClientM ()) -> CommandAction
 977     actionOnRendered ansi' m item = do
 978         ais <- gets clientActiveIdentities
 979         liftIO (renderMimed ansi' (historyUri item) ais (historyGeminatedMimedData item)) >>=
 980             either printErr m
 981
 982     actionOfCommand :: (String, [CommandArg]) -> Maybe CommandAction
 983     actionOfCommand (c,_) | restrictedMode && notElem c (commands True) = Nothing
 984     actionOfCommand ("show",_) = Just . actionOnRendered ansi $ liftIO . mapM_ T.putStrLn
 985     actionOfCommand ("page",_) = Just $ actionOnRendered ansi doPage
 986     actionOfCommand ("links",_) = Just $ \item -> do
 987         ais <- gets clientActiveIdentities
 988         let cl = childLink =<< historyChild item
 989             linkLine n (Link uri desc) =
 990                 applyIf (cl == Just (n-1)) (bold "* " <>) $
 991                 T.pack ('[' : show n ++ "] ")
 992                     <> showUriRefFull ansi ais (historyUri item) uri
 993                     <> if T.null desc then "" else " " <>
 994                         applyIf ansi (withColourStr Cyan) desc
 995         doPage . zipWith linkLine [1..] . extractLinksMimed . historyGeminatedMimedData $ item
 996
 997     actionOfCommand ("mark", CommandArg mark _ : _) |
 998         Just n <- readMay mark :: Maybe Int = Just $ \item -> do
 999             liftIO $ slurpItem item
1000             modify $ \s -> s { clientSessionMarks = M.insert n item $ clientSessionMarks s }
1001     actionOfCommand ("mime",_) = Just $ liftIO . putStrLn . showMimeType . historyMimedData
1002     actionOfCommand ("save", []) = actionOfCommand ("save", [CommandArg "" savesDir])
1003     actionOfCommand ("save", CommandArg _ path : _) = Just $ \item -> liftIO . doRestricted . RestrictedIO $ do
1004         createDirectoryIfMissing True savesDir
1005         homePath <- getHomeDirectory
1006         let path'
1007                 | take 2 path == "~/" = homePath </> drop 2 path
1008                 | take 1 path == "/" || take 2 path == "./" || take 3 path == "../" = path
1009                 | otherwise = savesDir </> path
1010             body = mimedBody $ historyMimedData item
1011             uri = historyUri item
1012             name = fromMaybe (fromMaybe "" $ uriRegName uri) . lastMay .
1013                 filter (not . null) $ pathSegments uri
1014         handle printIOErr . void . runMaybeT $ do
1015             lift $ mkdirhierto path'
1016             isDir <- lift $ doesDirectoryExist path'
1017             let fullpath = if isDir then path' </> name else path'
1018             lift (doesDirectoryExist fullpath) >>? do
1019                 lift . printErr $ "Path " ++ show fullpath ++ " exists and is directory"
1020                 mzero
1021             lift (doesFileExist fullpath) >>?
1022                 guard =<< lift (promptYN False $ "Overwrite " ++ show fullpath ++ "?")
1023             lift $ do
1024                 putStrLn $ "Saving to " ++ fullpath
1025                 t0 <- timeCurrentP
1026                 BL.writeFile fullpath =<< interleaveProgress t0 body
1027
1028     actionOfCommand ("!", CommandArg _ cmd : _) = Just $ \item -> liftIO . handle printIOErr . doRestricted .
1029         shellOnData noConfirm cmd userDataDir (historyEnv item) . mimedBody $ historyMimedData item
1030
1031     actionOfCommand ("view",_) = Just $ \item ->
1032         let mimed = historyMimedData item
1033             mimetype = showMimeType mimed
1034             body = mimedBody mimed
1035         in liftIO . handle printIOErr . doRestricted $ runMailcap noConfirm "view" userDataDir mimetype body
1036     actionOfCommand ("|", CommandArg _ cmd : _) = Just $ \item -> liftIO . handle printIOErr . doRestricted $
1037         pipeToShellLazily cmd (historyEnv item) . mimedBody $ historyMimedData item
1038     actionOfCommand ("||", args) = Just $ pipeRendered ansi args
1039     actionOfCommand ("||-", args) = Just $ pipeRendered False args
1040     actionOfCommand ("cat",_) = Just $ liftIO . BL.putStr . mimedBody . historyMimedData
1041     actionOfCommand ("at", CommandArg _ str : _) = Just $ \item ->
1042         doSubCommand (cState { clientCurrent = Just item }) blockGo str
1043     actionOfCommand _ = Nothing
1044
1045     pipeRendered :: Bool -> [CommandArg] -> CommandAction
1046     pipeRendered ansi' args item = (\action -> actionOnRendered ansi' action item) $ \ls ->
1047         liftIO . void . runMaybeT $ do
1048             cmd <- case args of
1049                 [] -> maybe notSet
1050                     (\s -> if null s then notSet else return s) =<<
1051                     liftIO (lookupEnv "PAGER")
1052                     where
1053                     notSet = printErr "Please set $PAGER or give a command to run" >> mzero
1054                 (CommandArg _ cmd : _) -> return cmd
1055             lift . doRestricted . pipeToShellLazily cmd (historyEnv item) . T.encodeUtf8 $ T.unlines ls
1056
1057     doSubCommand :: ClientState -> Bool -> String -> ClientM ()
1058     doSubCommand s block str = void . runMaybeT $ do
1059         cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
1060         lift $ handleCommandLine cOpts s block cl
1061
1062     setCurr :: HistoryItem -> ClientM ()
1063     setCurr i =
1064         let isJump = isNothing $ curr >>= pathItemByUri i . historyUri
1065         in do
1066             when isJump $ modify $ \s -> s { clientJumpBack = curr }
1067             modify $ \s -> s { clientCurrent = Just i }
1068
1069     doDefault :: HistoryItem -> ClientM ()
1070     doDefault item =
1071         maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction
1072
1073     goHistory :: HistoryItem -> ClientM ()
1074     goHistory _ | blockGo = printErr "Can't go anywhere now."
1075     goHistory item = do
1076         dropUriFromQueues uri
1077         showUri uri
1078         setCurr item
1079         doDefault item
1080         where uri = historyUri item
1081
1082     goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM ()
1083     goUri _ _ _ | blockGo = printErr "Can't go anywhere now."
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                 let updateParent i =
1091                         -- Lazily recursively update the links in the doubly linked list
1092                         let i' = i { historyParent = updateParent . updateChild i' <$> historyParent i }
1093                         in i'
1094                     updateChild i' i = i { historyChild = setChild <$> historyChild i }
1095                         where setChild c = c { childItem = i' }
1096                     glueOrigin (HistoryOrigin o l) = updateParent $ o { historyChild = Just $ HistoryChild item' l }
1097                     item' = item { historyParent = glueOrigin <$> origin }
1098                 setCurr item'
1099                 doDefault item
1100                 liftIO $ slurpItem 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 \"|\"?"