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