diohsc 0.1.13 → 0.1.14

raw patch · 21 files changed

+1599/−1306 lines, 21 files

Files

• ANSIColour.hs +9/−1
• CHANGELOG.md +4/−0
• ClientOptions.hs +26/−0
• ClientState.hs +71/−0
• Command.hs +5/−1
• CommandLine.hs +3/−1
• GeminiProtocol.hs +3/−2
• History.hs +66/−0
• LineClient.hs +942/−0
• Makefile +1/−1
• PrintFancy.hs +22/−0
• Queue.hs +64/−0
• ResolveTarget.hs +163/−0
• RunExternal.hs +31/−9
• Slurp.hs +4/−4
• Target.hs +32/−0
• TextGemini.hs +10/−7
• Version.hs +1/−1
• diohsc.cabal +9/−1
• diohsc.hs +121/−1272
• diohscrc.sample +12/−6

@@ -29,6 +29,7 @@     , splitAtVisible     , escapePromptCSI     , sanitiseForDisplay+    , stripControl     , Colour(..)     ) where @@ -156,8 +157,15 @@             isCSI = T.take 1 post' == "["         in pre <> (if isCSI then "\ESC" else "\\ESC") <> sanitiseNonCSI post' +-- |strip all C0 and C1 control chars+stripControl :: T.Text -> T.Text+stripControl = T.filter $ (>= 0) . wcwidth++-- |strip all C0 and C1 control chars except tab, and esc where it introduces+-- a CSI escape sequence. (Might be even better to strip all but SGR, but that+-- would require more parsing.) sanitiseForDisplay :: T.Text -> T.Text-sanitiseForDisplay = sanitiseNonCSI . T.filter (\c -> c == '\ESC' || wcwidth c >= 0)+sanitiseForDisplay = sanitiseNonCSI . T.filter (\c -> c `elem` ['\ESC','\t'] || wcwidth c >= 0)  -- |append \STX to each CSI sequence, as required in Haskeline prompts. -- See https://github.com/judah/haskeline/wiki/ControlSequencesInPrompt

@@ -2,6 +2,10 @@ This file covers only non-trivial user-visible changes; see the git log for full gory details. +# 0.1.14+* Run $EDITOR on input/query ending with backslash+* Strip all control characters (including ANSI formatting) outside preformatted blocks+ # 0.1.13 * Set CLIENT_CERT and CLIENT_KEY environment variables when invoking external commands * Improve wrapping of lines with words longer than the screen width

@@ -0,0 +1,26 @@+-- This file is part of Diohsc+-- Copyright (C) 2020-23 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program.  If not, see http://www.gnu.org/licenses/.++module ClientOptions where++import           System.IO++import           GeminiProtocol (RequestContext)++-- |Immutable options set at startup+data ClientOptions = ClientOptions+    { cOptUserDataDir    :: FilePath+    , cOptInteractive    :: Bool+    , cOptAnsi           :: Bool+    , cOptGhost          :: Bool+    , cOptRestrictedMode :: Bool+    , cOptRequestContext :: RequestContext+    , cOptLogH           :: Maybe Handle+    }

@@ -0,0 +1,71 @@+-- This file is part of Diohsc+-- Copyright (C) 2020-23 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program.  If not, see http://www.gnu.org/licenses/.++module ClientState where++import           Control.Monad.State (StateT, modify)+import           Data.Hash           (Hash)+import           Text.Regex          (Regex)++import qualified Data.Map            as M+import qualified Data.Set            as S+import qualified Data.Text.Lazy      as T++import           ActiveIdentities+import           Alias+import qualified BStack+import           CommandLine+import           History+import           Marks+import           Queue+import           Request+import           TextGemini          (PreOpt (..))++data ClientConfig = ClientConfig+    { clientConfDefaultAction     :: (String, [CommandArg])+    , clientConfProxies           :: M.Map String Host+    , clientConfGeminators        :: [(String,(Regex,String))]+    , clientConfRenderFilter      :: Maybe String+    , clientConfPreOpt            :: PreOpt+    , clientConfLinkDescFirst     :: Bool+    , clientConfMaxLogLen         :: Int+    , clientConfMaxWrapWidth      :: Int+    , clientConfNoConfirm         :: Bool+    , clientConfVerboseConnection :: Bool+    }++defaultClientConfig :: ClientConfig+defaultClientConfig = ClientConfig ("page", []) M.empty [] Nothing PreOptPre False 1000 80 False False++data ClientState = ClientState+    { clientCurrent          :: Maybe HistoryItem+    , clientJumpBack         :: Maybe HistoryItem+    , clientLog              :: BStack.BStack T.Text+    , clientVisited          :: S.Set Hash+    , clientQueues           :: QueueMap+    , clientActiveIdentities :: ActiveIdentities+    , clientMarks            :: Marks+    , clientSessionMarks     :: M.Map Int HistoryItem+    , clientAliases          :: Aliases+    , clientConfig           :: ClientConfig+    }++type ClientM = StateT ClientState IO++type CommandAction = HistoryItem -> ClientM ()++emptyClientState :: ClientState+emptyClientState = ClientState Nothing Nothing BStack.empty S.empty M.empty M.empty emptyMarks M.empty defaultAliases defaultClientConfig++modifyCConf :: (ClientConfig -> ClientConfig) -> ClientM ()+modifyCConf f = modify $ \s -> s { clientConfig = f $ clientConfig s }++modifyQueues :: (QueueMap -> QueueMap) -> ClientM ()+modifyQueues f = modify $ \s -> s { clientQueues = f $ clientQueues s }

@@ -470,10 +470,14 @@             , "  \\t   : tab"             , "  \\xHH : byte with given hex encoding"             , "  \\\\   : backslash"+            , "A backslash at the end of the line will load $EDITOR to edit the line."+            , ""+            , "Backslash is also interpreted this way in input prompted by a server."             ]         "repl" -> [ "TARGET {repl}: enter read-eval-print-loop,"             , "in which each line of input is used as a query string at the target."-            , "To return to normal command mode, enter an empty query or ^C or ^D." ]+            , "To return to normal command mode, enter an empty query or ^C or ^D."+            , "Backslash escaping is performed as per {query}." ]         "alias" ->             [ "{alias} ALIAS COMMANDLINE: add an alias"             , "{alias} ALIAS: delete an existing alias"

@@ -130,7 +130,9 @@ escapedArg = escapedWhile $ noneOf " "  escapedWhile :: Parser Char -> Parser String-escapedWhile c = many1 $ (char '\\' >> anyChar) <|> c+escapedWhile c = many1 $+    -- Allow escaping chars with \\, but preserve terminal \\+    (char '\\' >> (anyChar <|> (eof >> pure '\\'))) <|> c  nat :: Parser Int nat = read <$> many1 digit

@@ -53,6 +53,7 @@ import qualified Data.Text.Lazy             as T import qualified Data.Text.Lazy.Encoding    as T +import           ANSIColour import           BoundedBSChan import           ClientCert import           ClientSessionManager@@ -475,9 +476,9 @@     parseResponse resp =         let (header, rest) = BLC.break (== '\r') resp             body = BL.drop 2 rest-            statusString = T.unpack . T.decodeUtf8 . BL.take 2 $ header+            statusString = T.unpack . stripControl . T.decodeUtf8 . BL.take 2 $ header             separator = BL.take 1 . BL.drop 2 $ header-            meta = T.unpack . T.decodeUtf8 . BL.drop 3 $ header+            meta = T.unpack . stripControl . T.decodeUtf8 . BL.drop 3 $ header         in         if BL.take 2 rest /= "\r\n" then MalformedResponse BadHeaderTermination         else if separator `notElem` [""," ","\t"] -- ^allow \t for now, though it's against latest spec

@@ -0,0 +1,66 @@+-- This file is part of Diohsc+-- Copyright (C) 2020-23 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program.  If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE OverloadedStrings #-}++module History where+import           Data.List                (find)+import           Time.Types               (ElapsedP)++import qualified Codec.MIME.Type          as MIME+import qualified Data.Text.Encoding.Error as T+import qualified Data.Text.Lazy.Encoding  as T++import           GeminiProtocol+import           Request+import           TextGemini+import           URI++data HistoryChild = HistoryChild+    { childItem :: HistoryItem+    , childLink :: Maybe Int+    }++data HistoryOrigin = HistoryOrigin+    { originItem :: HistoryItem+    , originLink :: Maybe Int+    }++data HistoryItem = HistoryItem+    { historyRequest            :: Request+    , historyRequestTime        :: ElapsedP+    , historyMimedData          :: MimedData+    , historyGeminatedMimedData :: MimedData -- ^generated with lazy IO+    , historyParent             :: Maybe HistoryItem+    , historyChild              :: Maybe HistoryChild+    }++historyUri :: HistoryItem -> URI+historyUri = requestUri . historyRequest++historyAncestors :: HistoryItem -> [HistoryItem]+historyAncestors i = case historyParent i of+        Nothing -> []+        Just i' -> i' : historyAncestors i'++historyDescendants :: HistoryItem -> [HistoryItem]+historyDescendants i = case historyChild i of+        Nothing                  -> []+        Just (HistoryChild i' _) -> i' : historyDescendants i'++pathItemByUri :: HistoryItem -> URI -> Maybe HistoryItem+pathItemByUri i uri = find ((uri ==) . historyUri) $+    historyAncestors i ++ [i] ++ historyDescendants i++historyLinks :: HistoryItem -> [Link]+historyLinks item = case historyGeminatedMimedData item of+    MimedData (MIME.Type (MIME.Text "gemini") _) body ->+        extractLinks . parseGemini $ T.decodeUtf8With T.lenientDecode body+    _ -> []

@@ -0,0 +1,942 @@+-- This file is part of Diohsc+-- Copyright (C) 2020-23 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program.  If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}++module LineClient (lineClient) where++import qualified Codec.MIME.Parse             as MIME+import qualified Codec.MIME.Type              as MIME+import           Control.Applicative          (Alternative, empty)+import           Control.Monad.Catch+import           Control.Monad.State+import           Control.Monad.Trans.Maybe    (MaybeT (..), runMaybeT)++import           Data.Bifunctor               (second)+import qualified Data.ByteString.Lazy         as BL+import           Data.Char                    (toLower)+import           Data.Hash                    (hash)+import           Data.IORef                   (modifyIORef, newIORef, readIORef)+import           Data.List                    (intercalate, isPrefixOf,+                                               isSuffixOf, sort, stripPrefix)+import qualified Data.Map                     as M+import           Data.Maybe+import qualified Data.Set                     as S+import qualified Data.Text                    as TS+import qualified Data.Text.Encoding.Error     as T+import qualified Data.Text.Lazy               as T+import qualified Data.Text.Lazy.Encoding      as T+import qualified Data.Text.Lazy.IO            as T++import           Safe+import qualified System.Console.Haskeline     as HL+import qualified System.Console.Terminal.Size as Size+import           System.Directory+import           System.Environment+import           System.FilePath+import           System.IO.Unsafe             (unsafeInterleaveIO)++import           Text.Regex                   (matchRegex, mkRegexWithOpts)+import           Time.System                  (timeCurrentP)++import           ActiveIdentities+import           Alias+import           ANSIColour+import qualified BStack+import           ClientCert                   (KeyType (..))+import           ClientOptions+import           ClientState+import           Command+import           CommandLine+import           GeminiProtocol+import           History+import           Identity+import           Marks+import           MetaString+import           Mundanities+import           Pager+import           PrintFancy+import           Prompt                       hiding (promptYN)+import qualified Prompt+import           Queue+import           Request+import           ResolveTarget+import qualified RunExternal+import           RunExternal                  hiding (runRestrictedIO)+import           Slurp+import           Target+import           TextGemini+import           URI+import           Util++#ifdef ICONV+import           Codec.Text.IConv             (convert)+#endif++#ifdef MAGIC+import qualified Magic+#endif++getTermSize :: IO (Int,Int)+getTermSize = do+    Size.Window height width <- fromMaybe (Size.Window (2^(30::Int)) 80) <$> Size.size+    return (height,width)++lineClient :: ClientOptions -> [String] -> Bool -> HL.InputT ClientM ()+lineClient cOpts@ClientOptions{ cOptUserDataDir = userDataDir+        , cOptInteractive = interactive, cOptAnsi = ansi, cOptGhost = ghost} initialCommands repl = do+    (liftIO . readFileLines $ userDataDir </> "diohscrc") >>= mapM_ (handleLine' . T.unpack)+    lift addToQueuesFromFiles+    mapM_ handleLine' initialCommands+    when repl lineClient'+    unless ghost $ lift appendQueuesToFiles+    where+    handleLine' :: String -> HL.InputT ClientM Bool+    handleLine' line = lift get >>= \s -> handleLine cOpts s line++    lineClient' :: HL.InputT ClientM ()+    lineClient' = do+        cmd <- lift getPrompt >>= promptLineInputT+        quit <- case cmd of+            Nothing -> if interactive+                then printErrFancy ansi "Use \"quit\" to quit" >> return False+                else return True+            Just Nothing -> return True+            Just (Just line) -> handleLine' line+        lift addToQueuesFromFiles+        unless quit lineClient'++    addToQueuesFromFiles :: ClientM ()+    addToQueuesFromFiles | ghost = return ()+        | otherwise = do+            qfs <- ignoreIOErr $ liftIO findQueueFiles+            forM_ qfs $ \(qfile, qname) ->+                modifyQueues . enqueue (QueueSpec qname Nothing) <=<+                    ignoreIOErr . liftIO $+                    mapMaybe queueLine <$> readFileLines qfile <* removeFile qfile+            ignoreIOErr . liftIO $ removeDirectory queuesDir+        where+        findQueueFiles :: IO [(FilePath,String)]+        findQueueFiles = do+            qf <- (\e -> [(queueFile, "") | e]) <$> doesFileExist queueFile+            qfs <- ((\qn -> (queuesDir </> qn, qn)) <$>) <$> listDirectory queuesDir+            return $ qf <> qfs+        queueLine :: T.Text -> Maybe QueueItem+        queueLine s = QueueURI Nothing <$> (parseUriAsAbsolute . escapeIRI $ T.unpack s)++    appendQueuesToFiles :: ClientM ()+    appendQueuesToFiles = do+        queues <- gets $ M.toList . clientQueues+        liftIO $ createDirectoryIfMissing True queuesDir+        liftIO $ forM_ queues appendQueue+        where+        appendQueue (_, []) = pure ()+        appendQueue (qname, queue) =+            let qfile = case qname of+                    "" -> queueFile+                    s  -> queuesDir </> s+            in warnIOErr $ BL.appendFile qfile .+                T.encodeUtf8 . T.unlines $ T.pack . show . queueUri <$> queue++    queueFile, queuesDir :: FilePath+    queueFile = userDataDir </> "queue"+    queuesDir = userDataDir </> "queues"++    getPrompt :: ClientM String+    getPrompt = do+        queue <- gets $ M.findWithDefault [] "" . clientQueues+        curr <- gets clientCurrent+        proxies <- gets $ clientConfProxies . clientConfig+        ais <- gets clientActiveIdentities+        let queueStatus :: Maybe String+            queueStatus = guard (not $ null queue) >> return (show (length queue) ++ "~")+            colour = applyIf ansi . withColourStr+            bold = applyIf ansi withBoldStr+            uriStatus :: Int -> URI -> String+            uriStatus w uri =+                let fullUriStr = stripGem $ show uri+                    stripGem s = fromMaybe s $ stripPrefix "gemini://" s+                    mIdName = (identityName <$>) $ findIdentity ais =<< requestOfProxiesAndUri proxies uri+                    idStr = flip (maybe "") mIdName $ \idName ->+                        let abbrId = length idName > 8 && length fullUriStr + 2 + length idName > w - 2+                        in "[" ++ (if abbrId then ".." ++ take 6 idName else idName) ++ "]"+                    abbrUri = length fullUriStr + length idStr > w - 2+                    uriFormat = colour BoldMagenta+                    uriStr = if abbrUri+                        then+                            let abbrUriChars = w - 4 - length idStr+                                preChars = abbrUriChars `div` 2+                                postChars = abbrUriChars - preChars+                            in uriFormat (take preChars fullUriStr) <>+                            ".." <>+                            uriFormat (drop (length fullUriStr - postChars) fullUriStr)+                        else uriFormat fullUriStr+                in uriStr +++                    (if null idStr then "" else colour Green idStr)+            prompt :: Int -> String+            prompt maxPromptWidth =+                ((applyIf ansi withReverseStr $ colour BoldCyan "%%%") ++)+                    . (" " ++) . (++ bold "> ") . unwords $ catMaybes+                    [ queueStatus+                    , uriStatus (maxPromptWidth - 5 - maybe 0 ((+1) . length) queueStatus)+                        . historyUri <$> curr+                    ]+        prompt . min 40 . (`div` 2) . snd <$> liftIO getTermSize++handleLine :: ClientOptions -> ClientState -> String -> HL.InputT ClientM Bool+handleLine cOpts@ClientOptions{ cOptAnsi = ansi } s line = handle backupHandler . catchInterrupts $ case parseCommandLine line of+    Left err -> printErrFancy ansi err >> return False+    Right (CommandLine Nothing (Just (c,_))) | c `isPrefixOf` "quit" -> return True+    Right cline -> handleCommandLine cOpts s False cline >> return False+    where+    catchInterrupts = HL.handleInterrupt (printErrFancy ansi "Interrupted." >> return False) . HL.withInterrupt . lift+    backupHandler :: SomeException -> HL.InputT ClientM Bool+    backupHandler = (>> return False) . printErrFancy ansi . ("Unhandled exception: " <>) . show++handleCommandLine :: ClientOptions -> ClientState -> Bool -> CommandLine -> ClientM ()+handleCommandLine+        cOpts@(ClientOptions userDataDir interactive ansi ghost restrictedMode requestContext logH)+        cState@(ClientState curr jumpBack cLog visited queues _ marks sessionMarks aliases+            (ClientConfig defaultAction proxies geminators renderFilter preOpt linkDescFirst maxLogLen maxWrapWidth confNoConfirm verboseConnection))+        blockGo+    = \(CommandLine mt mcas) -> case mcas of+        Just (c,args) | Just (Alias _ (CommandLine mt' mcas')) <- lookupAlias c aliases ->+            let mcas'' = (, drop 1 args) . commandArgArg <$> headMay args+                appendCArgs (c',as') = (c', (appendTail <$> as') ++ args)+                    where+                    appendTail arg@(CommandArg a' t') = case args of+                        []                   -> arg+                        (CommandArg _ t : _) -> CommandArg a' $ t' <> " " <> t+            in handleCommandLine' (mt' `mplus` mt) $+                (appendCArgs <$> mcas') `mplus` mcas''+        _ -> handleCommandLine' mt mcas++    where++    -- Remark: we handle haskell's "configurations problem" by having the below all within the scope+    -- of the ClientOptions parameter. This is nicer to my mind than the heavier approaches of+    -- simulating global variables or threading a Reader monad throughout. The downside is that this+    -- module can't be split as much as it ought to be.+    -- Similar remarks go for `GeminiProtocol.makeRequest`.++    onRestriction :: IO ()+    onRestriction = printErr "This is not allowed in restricted mode."++    doRestricted :: Monoid a => RestrictedIO a -> IO a+    doRestricted m | restrictedMode = onRestriction >> return mempty+        | otherwise = RunExternal.runRestrictedIO m++    doRestrictedAlt :: Alternative f => RestrictedIO (f a) -> IO (f a)+    doRestrictedAlt m | restrictedMode = onRestriction >> return empty+        | otherwise = RunExternal.runRestrictedIO m++    doRestrictedFilter :: (a -> RestrictedIO a) -> (a -> IO a)+    doRestrictedFilter f | restrictedMode = \a -> do+            onRestriction+            return a+        | otherwise = RunExternal.runRestrictedIO . f++    printErr, printInfo :: MonadIO m => String -> m ()+    printErr = printErrFancy ansi+    printInfo = printInfoFancy ansi++    printIOErr :: IOError -> IO ()+    printIOErr = printErr . show++    noConfirm :: Bool+    noConfirm = confNoConfirm || not interactive++    confirm :: Applicative m => m Bool -> m Bool+    confirm | noConfirm = const $ pure True+        | otherwise = id++    promptYN = Prompt.promptYN interactive++    colour :: MetaString a => Colour -> a -> a+    colour = applyIf ansi . withColourStr+    bold :: MetaString a => a -> a+    bold = applyIf ansi withBoldStr++    isVisited :: URI -> Bool+    isVisited uri = S.member (hash $ show uri) visited++    requestOfUri = requestOfProxiesAndUri proxies++    idAtUri :: ActiveIdentities -> URI -> Maybe Identity+    idAtUri ais uri = findIdentity ais =<< requestOfUri uri++    showUriRefFull :: MetaString a => Bool -> ActiveIdentities -> URI -> URIRef -> a+    showUriRefFull ansi' ais base ref = showUriFull ansi' ais (Just base) $ relativeTo ref base++    showUriFull :: MetaString a => Bool -> ActiveIdentities -> Maybe URI -> URI -> a+    showUriFull ansi' ais base uri =+        let scheme = uriScheme uri+            handled = scheme `elem` ["gemini","file"] || M.member scheme proxies+            inHistory = isJust $ curr >>= flip pathItemByUri uri+            activeId = isJust $ idAtUri ais uri+            col = if inHistory && not activeId then BoldBlue else case (isVisited uri,handled) of+                (True,True)   -> Yellow+                (False,True)  -> BoldYellow+                (True,False)  -> Red+                (False,False) -> BoldRed+            s = case base of+                Nothing -> show uri+                Just b  -> show $ relativeFrom uri b+        in fromString (applyIf ansi' (withColourStr col) s) <> case idAtUri ais uri of+            Nothing    -> ""+            Just ident -> showIdentity ansi' ident++    displayUri :: MetaString a => URI -> a+    displayUri = colour Yellow . fromString . show++    showUri :: URI -> ClientM ()+    showUri uri = do+        ais <- gets clientActiveIdentities+        liftIO . putStrLn $ showUriFull ansi ais Nothing uri++    addToLog :: URI -> ClientM ()+    addToLog uri = do+        let t = T.pack $ show uri+        modify $ \s -> s+            { clientLog = BStack.push maxLogLen t $ clientLog s+            , clientVisited = S.insert (hash $ show uri) $ clientVisited s }+        unless ghost . liftIO $ maybe (return ()) (ignoreIOErr . (`T.hPutStrLn` t)) logH++    preprocessQuery :: String -> ClientM String+    preprocessQuery = (escapeQuery <$>) . liftIO . maybeEdit+        where+            maybeEdit :: String -> IO String+            maybeEdit s | lastMay s == Just '\\' =+                handle (\e -> printIOErr e >> pure s)+                    . doRestrictedFilter (editInteractively ansi userDataDir)+                    $ init s+            maybeEdit s = pure s++    expand :: String -> String+    expand = expandHelp ansi (fst <$> aliases) userDataDir++    idsPath = userDataDir </> "identities"+    savesDir = userDataDir </> "saves"+    marksDir = userDataDir </> "marks"++    historyEnv :: HistoryItem -> ClientM [(String,String)]+    historyEnv item = gets clientActiveIdentities >>= \ais -> pure $+        [ ("URI", show $ historyUri item)+        , ("MIMETYPE", showMimeType $ historyMimedData item) ] <>+        (maybe [] (identityEnvironment idsPath) . idAtUri ais $ historyUri item)++    setMark :: String -> URIWithIdName -> ClientM ()+    setMark mark uriId | markNameValid mark = do+        modify $ \s -> s { clientMarks = insertMark mark uriId $ clientMarks s }+        unless (mark `elem` tempMarks) . liftIO .+            handle printIOErr $ saveMark marksDir mark uriId+    setMark mark _ = printErr $ "Invalid mark name " ++ mark++    promptInput = if ghost then promptLine else promptLineWithHistoryFile inputHistPath+        where inputHistPath = userDataDir </> "inputHistory"++    handleCommandLine' :: Maybe PTarget -> Maybe (String, [CommandArg]) -> ClientM ()+    handleCommandLine' mt mcas = void . runMaybeT $ do+        ts <- case mt of+            Nothing -> return []+            Just pt -> either ((>> mzero) . printErr)+                (\ts -> mapM_ addTargetId ts >> return ts) $+                resolveTarget cState pt+        case mcas of+            Nothing -> lift $ handleBareTargets ts+            Just (s,as) -> do+                c' <- maybe (printErr (unknownCommand s) >> mzero)+                    return $ normaliseCommand s+                lift $ handleCommand ts (c',as)+        where+        unknownCommand s = "Unknown command \"" <> s <> "\". Type \"help\" for help."+        addTargetId :: Target -> MaybeT ClientM ()+        addTargetId (TargetIdUri idName uri) =+            liftIO (loadIdentity idsPath idName) >>= (\case+                (Nothing, _) -> printErr ("Bad URI: " ++ show uri) >> mzero+                (_, Nothing) -> printErr ("Unknown identity: " ++ showIdentityName ansi idName) >> mzero+                (Just req, Just ident) -> lift $ addIdentity req ident) . (requestOfUri uri,)+        addTargetId _ = return ()++    doPage :: [T.Text] -> ClientM ()+    doPage ls+        | interactive = do+            (height,width) <- liftIO getTermSize+            let pageWidth = min maxWrapWidth (width - 4)+                perPage = height - min 3 (height `div` 4)+                doCmd str = get >>= \s -> doSubCommand s True str+            printLinesPaged pageWidth width perPage doCmd ls+        | otherwise = liftIO $ mapM_ T.putStrLn ls++    handleBareTargets :: [Target] -> ClientM ()+    handleBareTargets [] = return ()+    handleBareTargets (_:_:_) =+        printErr "Can only go to one place at a time. Try \"show\" or \"page\"?"+    handleBareTargets [TargetHistory item] = goHistory item+    handleBareTargets [TargetFrom origin uri] = goUri False (Just origin) uri+    handleBareTargets [t] = goUri False Nothing $ targetUri t+++    handleCommand :: [Target] -> (String, [CommandArg]) -> ClientM ()+    handleCommand _ (c,_) | restrictedMode && notElem c (commands True) =+        printErr "Command disabled in restricted mode"+    handleCommand [] ("help", args) = case args of+        []                 -> doPage . map (T.pack . expand) $ helpText+        CommandArg s _ : _ -> doPage . map (T.pack . expand) $ helpOn s+    handleCommand [] ("commands",_) = doPage $ T.pack . expand <$> commandHelpText+        where+        commandHelpText = ["Aliases:"] ++ (showAlias <$> aliases) +++            ["","Commands:"] ++ (('{' :) . (<> "}") <$> commands False)+        showAlias (a, Alias s _) = "{" <> a <> "}: " <> s++    handleCommand [] ("mark", []) =+        let ms = M.toAscList marks+            markLine (m, uriId) = let m' = showMinPrefix ansi (fst <$> ms) m+                in T.pack $ "'" <> m' <>+                    replicate (max 1 $ 16 - visibleLength (T.pack m')) ' ' <>+                    showUriWithId uriId+        in doPage $ markLine <$> ms+    handleCommand [] ("inventory",_) = do+        ais <- gets clientActiveIdentities+        let showNumberedUri :: Bool -> T.Text -> (Int,URI) -> T.Text+            showNumberedUri iter s (n,uri) = s <>+                (if iter && n == 1 then " "+                    else if iter && n == 2 then T.takeEnd 1 s+                    else T.pack (show n)) <>+                " " <> showUriFull ansi ais Nothing uri+            showIteratedItem s (n,item) = showNumberedUri True s (n, historyUri item)+            showNumberedItem s (n,item) = showNumberedUri False s (n, historyUri item)+            showIteratedQueueItem s (n, QueueURI _ uri) =+                showNumberedUri True s (n, uri)+            showIteratedQueueItem s (n, QueueHistory item) =+                showNumberedUri True s (n, historyUri item) <> " {fetched}"+            showJumpBack :: [T.Text]+            showJumpBack = maybeToList $ ("'' " <>) . showUriFull ansi ais Nothing . historyUri <$> jumpBack+        doPage . intercalate [""] . filter (not . null) $+            showJumpBack :+            [ showIteratedQueueItem (T.pack $ qname <> "~") <$> zip [1..] queue+                | (qname, queue) <- M.toList queues ]+            ++ [ showNumberedItem "'" <$> M.toAscList sessionMarks+            , (showIteratedItem "<" <$> zip [1..] (maybe [] (initSafe . historyAncestors) curr))+            ++ (("@  " <>) . showUriFull ansi ais Nothing . historyUri <$>+                maybeToList (curr >>= lastMay . historyAncestors))+            , showIteratedItem ">" <$> zip [1..] (maybe [] historyDescendants curr)+            ]+    handleCommand [] ("log",_) =+        let showLog (n,t) = "$" <> T.pack (show n) <> " " <> colour Yellow t+        in doPage $ showLog <$> zip [(1::Int)..] (BStack.toList cLog)+    handleCommand [] ("alias", CommandArg a _ : CommandArg _ str : _) = void . runMaybeT $ do+        c <- either ((>>mzero) . printErr) return $ parseCommand a+        when (c /= a) $ printErr ("Bad alias: " <> a) >> mzero+        cl <- either ((>>mzero) . printErr) return $ parseCommandLine str+        modify $ \s ->+                s { clientAliases = insertAlias a (Alias str cl) . deleteAlias a $ clientAliases s }+    handleCommand [] ("alias", [CommandArg a _]) =+        modify $ \s -> s { clientAliases = deleteAlias a $ clientAliases s }+    handleCommand [] ("set", []) = liftIO $ do+        let (c,args) = defaultAction+        putStrLn $ expand "{default_action}: " <> c <>+            maybe "" ((" "<>) . commandArgLiteralTail) (headMay args)+        putStrLn $ expand "{proxies}:"+        printMap showHost $ M.toAscList proxies+        putStrLn $ expand "{geminators}:"+        printMap id $ second snd <$> geminators+        putStrLn $ expand "{render_filter}: " <> fromMaybe "" renderFilter+        putStrLn $ expand "{pre_display}: " <> showPreOpt preOpt+        putStrLn $ expand "{link_desc_first}: " <> show linkDescFirst+        putStrLn $ expand "{log_length}: " <> show maxLogLen+        putStrLn $ expand "{max_wrap_width}: " <> show maxWrapWidth+        putStrLn $ expand "{no_confirm}: " <> show noConfirm+        putStrLn $ expand "{verbose_connection}: " <> show verboseConnection+        where+            printMap :: (a -> String) -> [(String,a)] -> IO ()+            printMap f as = mapM_ putStrLn $+                (\(k,e) -> "  " <> k <> " " <> f e) <$> as+    handleCommand [] ("set", CommandArg opt _ : val)+        | opt `isPrefixOf` "default_action" = case val of+            (CommandArg cmd _ : args) -> case actionOfCommand (cmd,args) of+                Just _ -> modifyCConf $ \c -> c { clientConfDefaultAction = (cmd,args) }+                Nothing -> printErr "Invalid action"+            _ -> printErr "Require value for option."+        | opt `isPrefixOf` "proxies" || opt `isPrefixOf` "proxy" = case val of+            (CommandArg scheme _ : val') ->+                let f = maybe (M.delete scheme) (M.insert scheme) $+                        parseHost . commandArgLiteralTail =<< headMay val'+                in modifyCConf $ \c -> c { clientConfProxies = f $ clientConfProxies c }+                    -- if only I'd allowed myself to use lenses, eh?+            [] -> printErr "Require mimetype to set geminator for."+        | opt `isPrefixOf` "geminators" = case val of+            (CommandArg patt _ : val') ->+                let f = maybe (filter $ (/= patt) . fst)+                        (\v -> (++ [(patt, (mkRegexWithOpts patt True True,+                            commandArgLiteralTail v))])) $+                        headMay val'+                in modifyCConf $ \c -> c { clientConfGeminators = f $ clientConfGeminators c }+            [] -> printErr "Require mimetype to set geminator for."+        | opt `isPrefixOf` "render_filter" =+            modifyCConf $ \c -> c { clientConfRenderFilter =+                commandArgLiteralTail <$> headMay val }+        | opt `isPrefixOf` "pre_display" = case val of+            [CommandArg s _] | map toLower s `isPrefixOf` "both" ->+                modifyCConf $ \c -> c { clientConfPreOpt = PreOptBoth }+            [CommandArg s _] | map toLower s `isPrefixOf` "pre" ->+                modifyCConf $ \c -> c { clientConfPreOpt = PreOptPre }+            [CommandArg s _] | map toLower s `isPrefixOf` "alt" ->+                modifyCConf $ \c -> c { clientConfPreOpt = PreOptAlt }+            _ -> printErr "Require \"both\" or \"pre\" or \"alt\" for pre_display"+        | opt `isPrefixOf` "link_desc_first" = case val of+            [CommandArg s _] | map toLower s `isPrefixOf` "true" ->+                modifyCConf $ \c -> c { clientConfLinkDescFirst = True }+            [CommandArg s _] | map toLower s `isPrefixOf` "false" ->+                modifyCConf $ \c -> c { clientConfLinkDescFirst = False }+            _ -> printErr "Require \"true\" or \"false\" as value for link_desc_first"+        | opt `isPrefixOf` "log_length" = case val of+            [CommandArg s _] | Just n <- readMay s, n >= 0 -> do+                modifyCConf $ \c -> c { clientConfMaxLogLen = n }+                modify $ \st -> st { clientLog = BStack.truncate n $ clientLog st }+            _ -> printErr "Require non-negative integer value for log_length"+        | opt `isPrefixOf` "max_wrap_width" = case val of+            [CommandArg s _] | Just n <- readMay s, n > 0 ->+                modifyCConf $ \c -> c { clientConfMaxWrapWidth = n }+            _ -> printErr "Require positive integer value for max_wrap_width"+        | opt `isPrefixOf` "no_confirm" = case val of+            [CommandArg s _] | map toLower s `isPrefixOf` "true" ->+                modifyCConf $ \c -> c { clientConfNoConfirm = True }+            [CommandArg s _] | map toLower s `isPrefixOf` "false" ->+                modifyCConf $ \c -> c { clientConfNoConfirm = False }+            _ -> printErr "Require \"true\" or \"false\" as value for no_confirm"+        | opt `isPrefixOf` "verbose_connection" = case val of+            [CommandArg s _] | map toLower s `isPrefixOf` "true" ->+                modifyCConf $ \c -> c { clientConfVerboseConnection = True }+            [CommandArg s _] | map toLower s `isPrefixOf` "false" ->+                modifyCConf $ \c -> c { clientConfVerboseConnection = False }+            _ -> printErr "Require \"true\" or \"false\" as value for verbose_connection"+        | otherwise = printErr $ "No such option \"" <> opt <> "\"."+    handleCommand [] cargs =+        case curr of+            Just item -> handleCommand [TargetHistory item] cargs+            Nothing -> printErr "No current location. Enter an URI, or type \"help\"."++    handleCommand ts ("add", args) = case parseQueueSpec $ commandArgArg <$> args of+        Nothing -> printErr "Bad arguments to 'add'."+        Just qs -> modifyQueues . enqueue qs $ targetQueueItem <$> ts++    handleCommand ts ("fetch", args) = case parseQueueSpec $ commandArgArg <$> args of+        Nothing -> printErr "Bad arguments to 'fetch."+        Just qs -> do+            -- XXX: we have to use an IORef to store the items, since+            -- CommandAction doesn't allow a return value.+            lRef <- liftIO $ newIORef []+            let add item = liftIO $ slurpItem item >> modifyIORef lRef (item:)+            forM_ ts $ \t -> case t of+                TargetHistory item -> add item+                _ -> modifyQueues (unqueue uri) >> doRequestUri uri add+                    where uri = targetUri t+            l <- liftIO $ reverse <$> readIORef lRef+            modifyQueues . enqueue qs $ QueueHistory <$> l++    handleCommand ts cargs =+        mapM_ handleTargetCommand ts+        where+        handleTargetCommand (TargetHistory item) | Just action <- actionOfCommand cargs =+            action item+        handleTargetCommand t | Just action <- actionOfCommand cargs =+            let uri = targetUri t+            in modifyQueues (unqueue uri) >> doRequestUri uri action+        handleTargetCommand (TargetHistory item) | ("repeat",_) <- cargs =+            goUri True (recreateOrigin <$> historyParent item) $ historyUri item+        handleTargetCommand (TargetHistory item) | ("repl",_) <- cargs =+            repl (recreateOrigin <$> historyParent item) $ historyUri item+        handleTargetCommand t | ("query", CommandArg _ str : _) <- cargs = do+            let origin = case t of+                    TargetHistory item -> Just $ HistoryOrigin item Nothing+                    TargetFrom o _     -> Just o+                    _                  -> Nothing+            str' <- preprocessQuery str+            goUri True origin . setQuery ('?':str') $ targetUri t+        handleTargetCommand t =+            handleUriCommand (targetUri t) cargs++        recreateOrigin :: HistoryItem -> HistoryOrigin+        recreateOrigin parent = HistoryOrigin parent $ childLink =<< historyChild parent++        handleUriCommand uri ("delete",[]) =+            modifyQueues $ unqueueFrom "" uri+        handleUriCommand uri ("delete",CommandArg qname _ : _) =+            modifyQueues $ unqueueFrom qname uri+        handleUriCommand uri ("repeat",_) = goUri True Nothing uri+        handleUriCommand uri ("uri",_) = showUri uri+        handleUriCommand uri ("mark", CommandArg mark _ : _)+            | Just _ <- readMay mark :: Maybe Int = error "Bad mark for uri"+            | otherwise = do+            ais <- gets clientActiveIdentities+            let mIdName = case findIdentity ais =<< requestOfUri uri of+                    Just ident | not $ isTemporary ident -> Just $ identityName ident+                    _ -> Nothing+            setMark mark $ URIWithIdName uri mIdName+        handleUriCommand uri ("identify", args) = case requestOfUri uri of+            Nothing -> printErr "Bad URI"+            Just req -> gets ((`findIdentityRoot` req) . clientActiveIdentities) >>= \case+                Just (root,(ident,_)) | null args -> endIdentityPrompted root ident+                _ -> void . runMaybeT $ do+                    ident <- MaybeT . liftIO $ case args of+                        CommandArg idName _ : args' ->+                            let tp = case args' of+                                    CommandArg ('e':'d':_) _ : _ -> KeyEd25519+                                    _                            -> KeyRSA+                            in getIdentity interactive ansi idsPath tp idName+                        [] -> if interactive+                            then getIdentityRequesting ansi idsPath+                            else getIdentity interactive ansi idsPath KeyRSA ""+                    lift $ addIdentity req ident+        handleUriCommand uri ("browse", args) = do+            ais <- gets clientActiveIdentities+            let envir = maybe [] (identityEnvironment idsPath) .+                    idAtUri ais . setSchemeDefault $ uri+            void . liftIO . runMaybeT $ do+                cmd <- case args of+                    [] -> maybe notSet+                        (\s -> if null s then notSet else return $ parseBrowser s) =<<+                            lift (lookupEnv "BROWSER")+                        where+                        notSet = printErr "Please set $BROWSER or give a command to run" >> mzero+                        -- |based on specification for $BROWSER in 'man 1 man'+                        parseBrowser :: String -> String+                        parseBrowser = subPercentOrAppend (show uri) . takeWhile (/=':')+                    (CommandArg _ c : _) -> return $ subPercentOrAppend (show uri) c+                lift $ confirm (confirmShell "Run" cmd) >>? doRestricted $ void (runShellCmd cmd envir)+        handleUriCommand uri ("repl",_) = repl Nothing uri+        handleUriCommand uri ("log",_) = addToLog uri >> modifyQueues (unqueue uri)++        handleUriCommand _ (c,_) = printErr $ "Bad arguments to command " <> c++        repl :: Maybe HistoryOrigin -> URI -> ClientM ()+        repl origin uri = repl' where+            repl' = liftIO (join <$> promptInput ">> ") >>= \case+                Nothing -> return ()+                Just query -> do+                    query' <- preprocessQuery query+                    goUri True origin . setQuery ('?':query') $ uri+                    repl'++    slurpItem :: HistoryItem -> IO ()+    slurpItem item = slurpNoisily (historyRequestTime item) . mimedBody $ historyMimedData item++    actionOnRendered :: Bool -> ([T.Text] -> ClientM ()) -> CommandAction+    actionOnRendered ansi' m item = do+        ais <- gets clientActiveIdentities+        liftIO (renderMimed ansi' (historyUri item) ais (historyGeminatedMimedData item)) >>=+            either printErr m++    actionOfCommand :: (String, [CommandArg]) -> Maybe CommandAction+    actionOfCommand (c,_) | restrictedMode && notElem c (commands True) = Nothing+    actionOfCommand ("show",_) = Just . actionOnRendered ansi $ liftIO . mapM_ T.putStrLn+    actionOfCommand ("page",_) = Just $ actionOnRendered ansi doPage+    actionOfCommand ("links",_) = Just $ \item -> do+        ais <- gets clientActiveIdentities+        let cl = childLink =<< historyChild item+            linkLine n (Link uri desc) =+                applyIf (cl == Just (n-1)) (bold "* " <>) $+                T.pack ('[' : show n ++ "] ")+                    <> showUriRefFull ansi ais (historyUri item) uri+                    <> if T.null desc then "" else " " <>+                        applyIf ansi (withColourStr Cyan) desc+        doPage . zipWith linkLine [1..] . historyLinks $ item++    actionOfCommand ("mark", CommandArg mark _ : _) |+        Just n <- readMay mark :: Maybe Int = Just $ \item -> do+            liftIO $ slurpItem item+            modify $ \s -> s { clientSessionMarks = M.insert n item $ clientSessionMarks s }+    actionOfCommand ("mime",_) = Just $ liftIO . putStrLn . showMimeType . historyMimedData+    actionOfCommand ("save", []) = actionOfCommand ("save", [CommandArg "" savesDir])+    actionOfCommand ("save", CommandArg _ path : _) = Just $ \item -> liftIO . doRestricted . RestrictedIO $ do+        createDirectoryIfMissing True savesDir+        homePath <- getHomeDirectory+        let path'+                | take 2 path == "~/" = homePath </> drop 2 path+                | take 1 path == "/" || take 2 path == "./" || take 3 path == "../" = path+                | otherwise = savesDir </> path+            body = mimedBody $ historyMimedData item+            uri = historyUri item+            name = fromMaybe (fromMaybe "" $ uriRegName uri) . lastMay .+                filter (not . null) $ pathSegments uri+        handle printIOErr . void . runMaybeT $ do+            lift $ mkdirhierto path'+            isDir <- lift $ doesDirectoryExist path'+            let fullpath = if isDir then path' </> name else path'+            lift (doesDirectoryExist fullpath) >>? do+                lift . printErr $ "Path " ++ show fullpath ++ " exists and is directory"+                mzero+            lift (doesFileExist fullpath) >>?+                guard =<< lift (promptYN False $ "Overwrite " ++ show fullpath ++ "?")+            lift $ do+                putStrLn $ "Saving to " ++ fullpath+                t0 <- timeCurrentP+                BL.writeFile fullpath =<< interleaveProgress t0 body++    actionOfCommand ("!", CommandArg _ cmd : _) = Just $ \item -> do+        env <- historyEnv item+        liftIO . handle printIOErr . doRestricted .+            shellOnData noConfirm cmd userDataDir env . mimedBody $ historyMimedData item++    actionOfCommand ("view",_) = Just $ \item ->+        let mimed = historyMimedData item+            mimetype = showMimeType mimed+            body = mimedBody mimed+        in liftIO . handle printIOErr . doRestricted $ runMailcap noConfirm "view" userDataDir mimetype body+    actionOfCommand ("|", CommandArg _ cmd : _) = Just $ \item -> do+        env <- historyEnv item+        liftIO . handle printIOErr . doRestricted $+            pipeToShellLazily cmd env . mimedBody $ historyMimedData item+    actionOfCommand ("||", args) = Just $ pipeRendered ansi args+    actionOfCommand ("||-", args) = Just $ pipeRendered False args+    actionOfCommand ("cat",_) = Just $ liftIO . BL.putStr . mimedBody . historyMimedData+    actionOfCommand ("at", CommandArg _ str : _) = Just $ \item ->+        doSubCommand (cState { clientCurrent = Just item }) blockGo str+    actionOfCommand _ = Nothing++    pipeRendered :: Bool -> [CommandArg] -> CommandAction+    pipeRendered ansi' args item = (\action -> actionOnRendered ansi' action item) $ \ls -> do+        env <- historyEnv item+        liftIO . void . runMaybeT $ do+            cmd <- case args of+                [] -> maybe notSet+                    (\s -> if null s then notSet else return s) =<<+                    liftIO (lookupEnv "PAGER")+                    where+                    notSet = printErr "Please set $PAGER or give a command to run" >> mzero+                (CommandArg _ cmd : _) -> return cmd+            lift . doRestricted . pipeToShellLazily cmd env . T.encodeUtf8 $ T.unlines ls++    doSubCommand :: ClientState -> Bool -> String -> ClientM ()+    doSubCommand s block str = void . runMaybeT $ do+        cl <- either ((>>mzero) . printErr) return $ parseCommandLine str+        lift $ handleCommandLine cOpts s block cl++    setCurr :: HistoryItem -> ClientM ()+    setCurr i =+        let isJump = isNothing $ curr >>= pathItemByUri i . historyUri+        in do+            when isJump $ modify $ \s -> s { clientJumpBack = curr }+            modify $ \s -> s { clientCurrent = Just i }++    doDefault :: HistoryItem -> ClientM ()+    doDefault item =+        maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction++    goHistory :: HistoryItem -> ClientM ()+    goHistory _ | blockGo = printErr "Can't go anywhere now."+    goHistory item = do+        modifyQueues $ unqueue uri+        showUri uri+        setCurr item+        doDefault item+        where uri = historyUri item++    goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM ()+    goUri _ _ _ | blockGo = printErr "Can't go anywhere now."+    goUri forceRequest origin uri = do+        modifyQueues $ unqueue uri+        activeId <- gets $ isJust . (`idAtUri` uri) . clientActiveIdentities+        case curr >>= flip pathItemByUri uri of+            Just i' | not (activeId || forceRequest) -> goHistory i'+            _ -> doRequestUri uri $ \item -> do+                let updateParent i =+                        -- Lazily recursively update the links in the doubly linked list+                        let i' = i { historyParent = updateParent . updateChild i' <$> historyParent i }+                        in i'+                    updateChild i' i = i { historyChild = setChild <$> historyChild i }+                        where setChild c = c { childItem = i' }+                    glueOrigin (HistoryOrigin o l) = updateParent $ o { historyChild = Just $ HistoryChild item' l }+                    item' = item { historyParent = glueOrigin <$> origin }+                setCurr item'+                doDefault item+                liftIO $ slurpItem item++    doRequestUri :: URI -> CommandAction -> ClientM ()+    doRequestUri uri0 action = doRequestUri' 0 uri0+        where+        doRequestUri' redirs uri+            | Just req <- requestOfUri uri = addToLog uri >> doRequest redirs req+            | otherwise = printErr $ "Bad URI: " ++ displayUri uri ++ (+                    let scheme = uriScheme uri+                    in if scheme /= "gemini" && isNothing (M.lookup scheme proxies)+                    then " : No proxy set for non-gemini scheme " ++ scheme ++ "; use \"browse\"?"+                    else "")++        doRequest :: Int -> Request -> ClientM ()+        doRequest redirs _ | redirs > 5 =+            printErr "Too many redirections!"+        doRequest redirs req@(NetworkRequest _ uri) = do+            (mId, ais) <- liftIO . useActiveIdentity noConfirm ansi req =<< gets clientActiveIdentities+            modify $ \s -> s { clientActiveIdentities = ais }+            printInfo $ ">>> " ++ showUriFull ansi ais Nothing uri+            let respBuffSize = 2 ^ (15::Int) -- 32KB max cache for response stream+            liftIO (makeRequest requestContext mId respBuffSize verboseConnection req)+                `bracket` either (\_ -> return ()) (liftIO . snd) $+                either+                    (printErr . displayException)+                    (handleResponse . fst)+            where+            handleResponse :: Response -> ClientM ()+            handleResponse (Input isPass prompt) = do+                let defaultPrompt = "[" ++ (if isPass then "PASSWORD" else "INPUT") ++ "]"+                (liftIO . (join <$>) . promptInput $+                        (if null prompt then defaultPrompt else prompt) ++ " > ") >>= \case+                    Nothing -> return ()+                    Just query -> do+                        query' <- preprocessQuery query+                        doRequestUri' redirs . setQuery ('?':query') $ uri++            handleResponse (Success mimedData) = doAction req mimedData++            handleResponse (Redirect isPerm to) = do+                ais <- gets clientActiveIdentities+                let uri' = to `relativeTo` uri+                    crossSite = uriRegName uri' /= uriRegName uri+                    crossScheme = uriScheme uri' /= uriScheme uri+                    crossScope = case idAtUri ais <$> [uri,uri'] of+                            [fromId,toId] -> isJust toId && fromId /= toId+                            _             -> False+                    warningStr = colour BoldRed+                proceed <- (isJust <$>) . lift . runMaybeT $ do+                    when crossSite $ guard <=< (liftIO . promptYN False) $+                        warningStr "Follow cross-site redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"+                    when crossScheme $ guard <=< (liftIO . promptYN False) $+                        warningStr "Follow cross-protocol redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"+                    when crossScope $ guard <=< (liftIO . promptYN False) $+                        warningStr "Follow redirect with identity " ++ showUriRefFull ansi ais uri to ++ warningStr "?"+                when proceed $ do+                    when (isPerm && not ghost) . mapM_ (updateMark uri') . marksWithUri uri =<< gets clientMarks+                    doRequestUri' (redirs + 1) uri'+                where updateMark uri' (mark,uriId) = do+                        conf <- confirm . liftIO . promptYN True $ "Update mark '" <> mark <> " to " <> show uri' <> " ?"+                        when conf . setMark mark $ uriId { uriIdUri = uri' }+            handleResponse (Failure code info) | 60 <= code && code <= 69 = void . runMaybeT $ do+                identity <- do+                        liftIO . putStrLn $ (case code of+                            60 -> "Server requests identification"+                            _ -> "Server rejects provided identification certificate" +++                                (if code == 61 then " as unauthorised" else if code == 62 then " as invalid" else ""))+                            ++ if null info then "" else ": " ++ info+                        guard interactive+                        MaybeT . liftIO $ getIdentityRequesting ansi idsPath+                lift $ do+                    addIdentity req identity+                    doRequest redirs req++            handleResponse (Failure code info) =+                printErr $ "Server returns failure: " ++ show code ++ " " ++ info+            handleResponse (MalformedResponse malformation) =+                printErr $ "Malformed response from server: " ++ show malformation++        doRequest redirs (LocalFileRequest path) | redirs > 0 = printErr "Ignoring redirect to local file."+            | otherwise = void . runMaybeT $ do+                (path', mimedData) <- MaybeT . liftIO . doRestrictedAlt . RestrictedIO . warnIOErrAlt $ do+                    let detectExtension = case takeExtension path of+                            -- |certain crucial filetypes we can't rely on magic to detect:+                            s | s `elem` [".gmi", ".gem", ".gemini"] -> Just "text/gemini"+                            ".md" -> Just "text/markdown"+                            ".html" -> Just "text/html"+                            _ -> Nothing+#ifdef MAGIC+                        detectPlain "text/plain" = fromMaybe "text/plain" detectExtension+                        detectPlain s = s+                    magic <- Magic.magicOpen [Magic.MagicMimeType]+                    Magic.magicLoadDefault magic+                    s <- detectPlain <$> Magic.magicFile magic path+#else+                    let s = if "/" `isSuffixOf` path then "inode/directory"+                            else fromMaybe "application/octet-stream" detectExtension+#endif+                    case MIME.parseMIMEType $ TS.pack s of+                        Nothing -> printErr ("Failed to parse mimetype string: " <> s) >> return Nothing+                        _ | s == "inode/directory" -> Just . (slashedPath,) . MimedData gemTextMimeType .+                            T.encodeUtf8 . T.unlines .+                            ((("=> " <>) . T.pack . escapePathString) <$>) . sort <$>+                                getDirectoryContents path+                            where slashedPath | "/" `isSuffixOf` path = path+                                    | otherwise = path <> "/"+                        Just mimetype -> Just . (path,) . MimedData mimetype <$> BL.readFile path+                lift $ doAction (LocalFileRequest path') mimedData++        doAction req mimedData = do+            t0 <- liftIO timeCurrentP+            geminated <- geminate mimedData+            action $ HistoryItem req t0 mimedData geminated Nothing Nothing+            where+            -- |returns MimedData with lazy IO+            geminate :: MimedData -> ClientM MimedData+            geminate mimed =+                let geminator = lookupGeminator $ showMimeType mimed+                in liftIO . unsafeInterleaveIO $ applyGeminator geminator+                where+                lookupGeminator mimetype =+                    listToMaybe [ gem | (_, (regex, gem)) <- geminators+                        , isJust $ matchRegex regex mimetype ]+                applyGeminator Nothing = return mimed+                applyGeminator (Just cmd) =+                    printInfo ("| " <> cmd) >>+                    MimedData gemTextMimeType <$>+                        doRestrictedFilter (filterShell cmd [("URI", show $ requestUri req)]) (mimedBody mimed)++        gemTextMimeType :: MIME.Type+        gemTextMimeType = MIME.Type (MIME.Text "gemini") []+++    addIdentity :: Request -> Identity -> ClientM ()+    addIdentity req identity = do+        ais <- gets clientActiveIdentities >>= liftIO . insertIdentity req identity+        modify $ \s -> s {clientActiveIdentities = ais}+    endIdentityPrompted :: Request -> Identity -> ClientM ()+    endIdentityPrompted root ident = do+        conf <- confirm $ liftIO . promptYN False $ "Stop using " +++            (if isTemporary ident then "temporary anonymous identity" else showIdentity ansi ident) +++            " at " ++ displayUri (requestUri root) ++ "?"+        when conf . modify $ \s ->+                s { clientActiveIdentities = deleteIdentity root $ clientActiveIdentities s }++    renderMimed :: Bool -> URI -> ActiveIdentities -> MimedData -> IO (Either String [T.Text])+    renderMimed ansi' uri ais (MimedData mime body) = case MIME.mimeType mime of+        MIME.Text textType -> do+            let extractCharsetParam (MIME.MIMEParam "charset" v) = Just v+                extractCharsetParam _                            = Nothing+                charset = TS.unpack . fromMaybe "utf-8" . msum . map extractCharsetParam $ MIME.mimeParams mime+                isUtf8 = map toLower charset `elem` ["utf-8", "utf8"]+#ifdef ICONV+                reencoder = if isUtf8 then id else+                    convert charset "UTF-8"+#else+                reencoder = id+            unless isUtf8 . printErr $+                "Warning: Treating unsupported charset " ++ show charset ++ " as utf-8"+#endif+            (_,width) <- getTermSize+            let pageWidth = if interactive+                then min maxWrapWidth (width - 4)+                else maxWrapWidth+            let bodyText = T.decodeUtf8With T.lenientDecode $ reencoder body+                applyFilter :: [T.Text] -> IO [T.Text]+                applyFilter = case renderFilter of+                    Nothing -> return+                    Just cmd -> (T.lines . T.decodeUtf8With T.lenientDecode <$>) .+                        doRestrictedFilter (filterShell cmd []) . BL.concat . (appendNewline . T.encodeUtf8 <$>)+                        where appendNewline = (`BL.snoc` 10)+            (Right <$>) . applyFilter $ case textType of+                    "gemini" ->+                        let opts = GemRenderOpts ansi' preOpt pageWidth linkDescFirst+                        in printGemDoc opts (showUriRefFull ansi' ais uri) $ parseGemini bodyText+                    _ -> T.stripEnd . stripControl <$> T.lines bodyText+        mimeType ->+            return . Left $ "No geminator for " ++ TS.unpack (MIME.showMIMEType mimeType) ++ " configured. Try \"save\", \"view\", \"!\", or \"|\"?"

@@ -1,4 +1,4 @@-VERSION=0.1.13+VERSION=0.1.14  GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa 

@@ -0,0 +1,22 @@+-- This file is part of Diohsc+-- Copyright (C) 2020-23 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program.  If not, see http://www.gnu.org/licenses/.++module PrintFancy where++import           Control.Monad.IO.Class (MonadIO, liftIO)+import           System.IO++import           ANSIColour++printErrFancy :: MonadIO m => Bool -> String -> m ()+printErrFancy ansi s = liftIO . hPutStrLn stderr . applyIf ansi (withColourStr BoldRed) $ "! " <> s++printInfoFancy :: MonadIO m => Bool -> String -> m ()+printInfoFancy ansi s = liftIO . hPutStrLn stderr $ applyIf ansi withBoldStr ". " <> s

@@ -0,0 +1,64 @@+-- This file is part of Diohsc+-- Copyright (C) 2020-23 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program.  If not, see http://www.gnu.org/licenses/.++module Queue where++import           Data.Char  (isAlpha)+import           Data.Maybe+import           Safe       (readMay)++import qualified Data.Map   as M++import           History+import           URI++data QueueItem+    = QueueURI (Maybe HistoryOrigin) URI+    | QueueHistory HistoryItem++queueUri :: QueueItem -> URI+queueUri (QueueURI _ uri)    = uri+queueUri (QueueHistory item) = historyUri item++type QueueMap = M.Map String [QueueItem]++data QueueSpec = QueueSpec+    { queueSpecName :: String+    , queueSpecPos  :: Maybe Int+    }++parseQueueSpec :: [String] -> Maybe QueueSpec+parseQueueSpec [] = Just $ QueueSpec "" Nothing+parseQueueSpec [a] | Just n <- readMay a = Just . QueueSpec "" $ Just n+parseQueueSpec (a:as) | not (null a), all isAlpha a+    , Just mn <- case as of+        []                          -> Just Nothing+        [a'] | Just n <- readMay a' -> Just (Just n)+        _                           -> Nothing+    = Just $ QueueSpec a mn+parseQueueSpec _ = Nothing++enqueue :: QueueSpec -> [QueueItem] -> QueueMap -> QueueMap+enqueue _ [] = id+enqueue (QueueSpec qname after) qs =+        M.alter (Just . insertInNubbedList after qs queueUri) qname+    where+        insertInNubbedList :: Eq b => Maybe Int -> [a] -> (a -> b) -> Maybe [a] -> [a]+        insertInNubbedList mn as f mbs =+            let bs = fromMaybe [] mbs+                (bs',bs'') = maybe (bs,[]) (`splitAt` bs) mn+                del as' = filter $ (`notElem` (f <$> as')) . f+            in del as bs' ++ as ++ del as bs''++unqueueFrom :: String -> URI -> QueueMap -> QueueMap+unqueueFrom qname uri = (`M.adjust` qname) . filter $ (/= uri) . queueUri++unqueue :: URI -> QueueMap -> QueueMap+unqueue uri = M.map . filter $ (/= uri) . queueUri

@@ -0,0 +1,163 @@+-- This file is part of Diohsc+-- Copyright (C) 2020-23 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program.  If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE LambdaCase #-}++module ResolveTarget (resolveTarget) where++import           Data.Char      (isUpper)+import           Data.Hash      (hash)+import           Data.Maybe+import           Safe+import           Text.Regex     (matchRegex, mkRegexWithOpts)++import qualified Data.Map       as M+import qualified Data.Set       as S+import qualified Data.Text.Lazy as T++import qualified BStack+import           ClientState    (ClientState (..))+import           CommandLine+import           History+import           Marks+import           Queue+import           Target+import           TextGemini+import           URI+import           Util           (maybeToEither)++resolveTarget :: ClientState -> PTarget -> Either String [Target]+resolveTarget (ClientState curr jumpBack cLog visited queues _ marks sessionMarks _ _) =+    resolveTarget'+    where+    resolveTarget' PTargetCurr =+        (:[]) . TargetHistory <$> maybeToEither "No current location" curr++    resolveTarget' PTargetJumpBack =+        (:[]) . TargetHistory <$> maybeToEither "'' mark not set" jumpBack++    resolveTarget' (PTargetMark s)+        | Just n <- readMay s =+            (:[]) . TargetHistory <$> maybeToEither ("Mark not set: " <> s) (M.lookup n sessionMarks)+        | otherwise =+            (:[]) . targetOfMark <$> maybeToEither ("Unknown mark: " <> s) (lookupMark s marks)+            where+            targetOfMark (URIWithIdName uri Nothing) = TargetUri uri+            targetOfMark (URIWithIdName uri (Just idName)) = TargetIdUri idName uri++    resolveTarget' (PTargetLog specs) =+        (TargetUri <$>) <$> resolveElemsSpecs "log entry" (matchPatternOn show) loggedUris specs++    resolveTarget' (PTargetQueue qname specs) =+        (queueTarget <$>) <$> resolveElemsSpecs "queue item"+            (matchPatternOn $ show . queueUri) queue specs+        where+        queue = M.findWithDefault [] qname queues+        queueTarget (QueueURI Nothing uri)  = TargetUri uri+        queueTarget (QueueURI (Just o) uri) = TargetFrom o uri+        queueTarget (QueueHistory item)     = TargetHistory item++    resolveTarget' (PTargetRoot base) =+        (rootOf <$>) <$> resolveTarget' base+        where+        rootOf :: Target -> Target+        rootOf (TargetHistory item)                  = rootOfItem item+        rootOf (TargetFrom (HistoryOrigin item _) _) = rootOfItem item+        rootOf t                                     = t+        rootOfItem item = TargetHistory . lastDef item $ historyAncestors item++    resolveTarget' (PTargetAncestors base specs) =+        concat <$> (mapM resolveAncestors =<< resolveTarget' base)+        where+        resolveAncestors :: Target -> Either String [Target]+        resolveAncestors (TargetHistory item) =+            resolveAncestors' $ historyAncestors item+        resolveAncestors (TargetFrom (HistoryOrigin item _) _) =+            resolveAncestors' $ item : historyAncestors item+        resolveAncestors _ = Left "No history"+        resolveAncestors' hist = (TargetHistory <$>) <$>+            resolveElemsSpecs "ancestor" (matchPatternOn $ show . historyUri)+                hist specs++    resolveTarget' (PTargetDescendants base specs) =+        concat <$> (mapM resolveDescendants =<< resolveTarget' base)+        where+        resolveDescendants :: Target -> Either String [Target]+        resolveDescendants (TargetHistory item) = (TargetHistory <$>) <$>+            resolveElemsSpecs "descendant" (matchPatternOn $ show . historyUri)+                (historyDescendants item) specs+        resolveDescendants _ = Left "No history"++    resolveTarget' (PTargetChild increasing noVisited base specs) =+        concat <$> (mapM resolveChild =<< resolveTarget' base)+        where+        resolveChild (TargetHistory item) =+            let itemLinks = historyLinks item+                b = case historyChild item of+                    Just (HistoryChild _ (Just b')) -> b'+                    _ | increasing                  -> -1+                    _                               -> length itemLinks+                slice | increasing = zip [b+1..] $ drop (b+1) itemLinks+                    | otherwise = zip (reverse [0..b-1]) . reverse $ take b itemLinks+                linkUnvisited (_,l) = not . isVisited $ linkUri l `relativeTo` historyUri item+                slice' | noVisited = filter linkUnvisited slice+                    | otherwise = slice+            in resolveLinkSpecs False item slice' specs+        resolveChild _ = Left "No known links"++    resolveTarget' (PTargetLinks noVisited base specs) =+        concat <$> (mapM resolveLinks =<< resolveTarget' base)+        where+        resolveLinks (TargetHistory item) =+            let itemLinks = historyLinks item+            in resolveLinkSpecs noVisited item (zip [0..] itemLinks) specs+        resolveLinks _ = Left "No known links"++    resolveTarget' (PTargetRef base s) =+        let makeRel r | base == PTargetCurr = r+            makeRel r@('/':_) = '.':r+            makeRel r = r+        in case parseUriReference . escapeIRI . escapeQueryPart $ makeRel s of+            Nothing -> Left $ "Failed to parse relative URI: " <> s+            Just ref -> map relTarget <$> resolveTarget' base+                where+                relTarget (TargetHistory item) = TargetFrom (HistoryOrigin item Nothing) $+                    ref `relativeTo` historyUri item+                relTarget (TargetFrom o uri) = TargetFrom o $ relativeTo ref uri+                relTarget t = TargetUri . relativeTo ref $ targetUri t++    resolveTarget' (PTargetAbs s) = case parseUriAsAbsolute . escapeIRI $ escapeQueryPart s of+        Nothing  -> Left $ "Failed to parse URI: " <> s+        Just uri -> return [TargetUri uri]++    resolveLinkSpecs :: Bool -> HistoryItem -> [(Int,Link)] -> ElemsSpecs -> Either String [Target]+    resolveLinkSpecs purgeVisited item slice specs =+        let isMatch s (_,l) = matchPattern s (show $ linkUri l) ||+                matchPattern s (T.unpack $ linkDescription l)+            linkTarg (n,l) =+                let uri = linkUri l `relativeTo` historyUri item+                in if purgeVisited && isVisited uri then Nothing+                    else Just $ TargetFrom (HistoryOrigin item $ Just n) uri+        in resolveElemsSpecs "link" isMatch slice specs >>= (\case+            []    -> Left "No such link"+            targs -> return targs) . mapMaybe linkTarg++    matchPattern :: String -> String -> Bool+    matchPattern patt =+        let regex = mkRegexWithOpts patt True (any isUpper patt)+        in isJust . matchRegex regex++    matchPatternOn :: (a -> String) -> String -> a -> Bool+    matchPatternOn f patt = matchPattern patt . f++    isVisited :: URI -> Bool+    isVisited uri = S.member (hash $ show uri) visited++    loggedUris = catMaybes $ (parseAbsoluteUri . escapeIRI . T.unpack <$>) $ BStack.toList cLog

@@ -12,21 +12,24 @@  module RunExternal where -import           Control.Concurrent   (forkIO)-import           Control.Monad        (void)-import           Control.Monad.Catch  (bracket_, finally)-import           Control.Monad.State  (State, put, runState)-import           Data.Char            (isAlphaNum)-import           System.Environment   (setEnv, unsetEnv)-import           System.Exit          (ExitCode)+import           Control.Concurrent        (forkIO)+import           Control.Monad             (msum, void)+import           Control.Monad.Catch       (bracket_, finally)+import           Control.Monad.State       (State, put, runState)+import           Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)+import           Data.Char                 (isAlphaNum)+import           Data.List                 (uncons)+import           System.Environment        (lookupEnv, setEnv, unsetEnv)+import           System.Exit               (ExitCode) import           System.IO-import           System.IO.Temp       (withTempFile)+import           System.IO.Temp            (withTempFile) import           System.Process -import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy      as BL  import           ANSIColour import           Mundanities+import           PrintFancy import           Prompt import           Util @@ -109,6 +112,25 @@  runShellCmd :: String -> [(String,String)] -> RestrictedIO ExitCode runShellCmd cmd envir = RestrictedIO . withExtraEnv envir $ spawnCommand cmd >>= waitForProcess++editInteractively :: Bool -> String -> String -> RestrictedIO String+editInteractively ansi dir s =+    RestrictedIO . withTempFile dir "runtmp" $ \path h -> do+        hPutStr h s+        hClose h+        mEditor <- runMaybeT . msum $ MaybeT <$>+            [ lookupEnv "EDITOR", lookupEnv "VISUAL" ]+        case mEditor of+            Nothing -> printErrFancy ansi "EDITOR environment variable unset" >> pure s+            Just editor -> do+                void $ rawSystem editor [path]+                (stripNewline <$>) $ openFile path ReadMode >>= hGetContents+    where+        stripNewline :: String -> String+        stripNewline = (. reverse) $ reverse . \cs ->+            case uncons cs of+                Just ('\n',cs') -> cs'+                _               -> cs  shellOnData :: Bool -> String -> FilePath -> [(String,String)] -> BL.ByteString -> RestrictedIO () shellOnData noConfirm cmd dir envir b = RestrictedIO . withTempFile dir "runtmp" $ \path h ->

@@ -28,9 +28,9 @@     let slurp _ _ n' [] = do             t' <- timeCurrentP             when (t' `timeDiffP` t1 > (Seconds 1, 0)) $ do-                putStrLn $ "\r\ESC[KReceived: " ++ humanBytes n'+                hPutStrLn stderr $ "\r\ESC[KReceived: " ++ humanBytes n'                     ++ "  " ++ humanRate n' (t' `timeDiffP` t0)-                hFlush stdout+                hFlush stderr             return []         slurp n t n' (c:cs) = unsafeInterleaveIO $ do             let n'' = n' + fromIntegral (BS.length c)@@ -38,9 +38,9 @@             if t' `timeDiffP` t > (Seconds 1, 0)             then do                 when (t' `timeDiffP` t1 > (Seconds 1, 0)) $ do-                    putStr $   "\r\ESC[KProgress: " ++ humanBytes n'+                    hPutStr stderr $   "\r\ESC[KProgress: " ++ humanBytes n'                         ++ "  " ++ humanRate (n' - n) (t' `timeDiffP` t)-                    hFlush stdout+                    hFlush stderr                 (c:) <$> slurp n'' t' n'' cs             else (c:) <$> slurp n t n'' cs         humanBytes n | n < 1024 = show n ++ "B"

@@ -0,0 +1,32 @@+-- This file is part of Diohsc+-- Copyright (C) 2020-23 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program.  If not, see http://www.gnu.org/licenses/.++module Target where++import           History+import           Queue+import           URI++data Target+    = TargetHistory HistoryItem+    | TargetFrom HistoryOrigin URI+    | TargetIdUri String URI+    | TargetUri URI++targetUri :: Target -> URI+targetUri (TargetHistory item) = historyUri item+targetUri (TargetFrom _ uri)   = uri+targetUri (TargetIdUri _ uri)  = uri+targetUri (TargetUri uri)      = uri++targetQueueItem :: Target -> QueueItem+targetQueueItem (TargetFrom o uri)   = QueueURI (Just o) uri+targetQueueItem (TargetHistory item) = QueueHistory item+targetQueueItem i                    = QueueURI Nothing $ targetUri i

@@ -68,30 +68,33 @@ printGemDoc (GemRenderOpts ansi preOpt width linkDescFirst)         showUri (GeminiDocument doc) = concatMap printLine doc     where-    printLine (TextLine line) = wrapWith "" False line+    printLine (TextLine line) = wrapWith "" False $ stripControl line     printLine (AltTextLine line)         | preOpt == PreOptPre || T.null line = []-        | otherwise = (:[]) $ applyIf ansi withBoldStr "`` " <> line+        | otherwise = (:[]) $ applyIf ansi withBoldStr "`` " <> stripControl line      printLine PreformatToggleLine = []      printLine (PreformattedLine alt line)         | preOpt == PreOptAlt && not (T.null alt) = []-        | otherwise = (:[]) $ applyIf ansi ((resetCode <>) . withBoldStr) "` " <> line+        | otherwise =+            -- We allow \t and CSI escape sequences in preformatted text only+            let sanitise = applyIf (not ansi) (stripCSI .) sanitiseForDisplay+            in (:[]) $ applyIf ansi ((resetCode <>) . withBoldStr) "` " <> sanitise line     printLine (HeadingLine level line) =         wrapWith (T.take (fromIntegral level) (T.repeat '#') <> " ") False         . applyIf ansi             ( applyIf (level /= 2) withUnderlineStr-            . applyIf (level < 3) withBoldStr ) $ line-    printLine (ItemLine line) = wrapWith "* " False line-    printLine (QuoteLine line) = wrapWith "> " True line+            . applyIf (level < 3) withBoldStr ) $ stripControl line+    printLine (ItemLine line) = wrapWith "* " False $ stripControl line+    printLine (QuoteLine line) = wrapWith "> " True $ stripControl line     printLine (ErrorLine line) = (:[]) $ applyIf ansi (withColourStr Red)         "! Formatting error in text/gemini: " <> line     printLine (LinkLine n (Link uri desc)) =         wrapWith (T.pack $ '[' : show (n+1) ++ if n+1 < 10 then "]  " else "] ") False             $ (if T.null desc then id                 else (if linkDescFirst then id else flip) (\a b -> a <> " " <> b)-                    $ applyIf ansi (withColourStr Cyan) desc)+                    $ applyIf ansi (withColourStr Cyan) (stripControl desc))                 (showUri uri)      wrapWith :: T.Text -> Bool -> T.Text -> [T.Text]

@@ -16,4 +16,4 @@ programName = "diohsc"  version :: String-version = "0.1.13"+version = "0.1.14"

@@ -1,6 +1,6 @@ cabal-version:      1.18 name:               diohsc-version:            0.1.13+version:            0.1.14 license:            GPL-3 license-file:       COPYING maintainer:         mbays@sdf.org@@ -54,22 +54,30 @@         BoundedBSChan         BStack         ClientCert+        ClientOptions          ClientSessionManager+        ClientState          Command         CommandLine         Fingerprint+        History          GeminiProtocol         Identity+        LineClient         Marks         MetaString         Mundanities         Opts         Pager+        PrintFancy         Prompt+        Queue          Request+        ResolveTarget         RunExternal         ServiceCerts         Slurp+        Target         TextGemini         URI         Util

@@ -12,1275 +12,124 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections     #-}--module Main where--import           Control.Applicative          (Alternative, empty)-import           Control.Monad.Catch-import           Control.Monad.State-import           Control.Monad.Trans.Maybe    (MaybeT (..), runMaybeT)-import           Data.Bifunctor               (second)-import           Data.Char                    (isAlpha, isUpper, toLower)-import           Data.Hash                    (Hash, hash)-import           Data.IORef                   (modifyIORef, newIORef, readIORef)-import           Data.List                    (find, intercalate, isPrefixOf,-                                               isSuffixOf, sort, stripPrefix)-import           Data.Maybe-import           Safe-import           System.Directory-import           System.Environment-import           System.Exit-import           System.FilePath-import           System.IO-import           System.IO.Unsafe             (unsafeInterleaveIO)-import           Text.Regex                   (Regex, matchRegex,-                                               mkRegexWithOpts)-import           Time.System                  (timeCurrentP)-import           Time.Types                   (ElapsedP)--import qualified Data.ByteString.Lazy         as BL--import qualified Codec.MIME.Parse             as MIME-import qualified Codec.MIME.Type              as MIME-import qualified Data.Map                     as M-import qualified Data.Set                     as S-import qualified Data.Text                    as TS-import qualified Data.Text.Encoding.Error     as T-import qualified Data.Text.Lazy               as T-import qualified Data.Text.Lazy.Encoding      as T-import qualified Data.Text.Lazy.IO            as T-import qualified System.Console.Haskeline     as HL-import qualified System.Console.Terminal.Size as Size--import           ActiveIdentities-import           Alias-import           ANSIColour-import qualified BStack-import           ClientCert                   (KeyType (..))-import           Command-import           CommandLine-import           GeminiProtocol-import           Identity-import           Marks-import           MetaString-import           Mundanities-import           Opts-import           Pager-import           Prompt                       hiding (promptYN)-import qualified Prompt-import           Request-import qualified RunExternal-import           RunExternal                  hiding (runRestrictedIO)-import           Slurp-import           TextGemini-import           URI-import           Util-import           Version--#ifndef WINDOWS-import           System.Posix.Files           (ownerModes, setFileMode)-#endif--#ifdef ICONV-import           Codec.Text.IConv             (convert)-#endif--#ifdef MAGIC-import qualified Magic-#endif---- |Immutable options set at startup-data ClientOptions = ClientOptions-    { cOptUserDataDir    :: FilePath-    , cOptInteractive    :: Bool-    , cOptAnsi           :: Bool-    , cOptGhost          :: Bool-    , cOptRestrictedMode :: Bool-    , cOptRequestContext :: RequestContext-    , cOptLogH           :: Maybe Handle-    }--data HistoryChild = HistoryChild-    { childItem :: HistoryItem-    , childLink :: Maybe Int-    }--data HistoryOrigin = HistoryOrigin-    { originItem :: HistoryItem-    , originLink :: Maybe Int-    }--data HistoryItem = HistoryItem-    { historyRequest            :: Request-    , historyRequestTime        :: ElapsedP-    , historyMimedData          :: MimedData-    , historyGeminatedMimedData :: MimedData -- ^generated with lazy IO-    , historyParent             :: Maybe HistoryItem-    , historyChild              :: Maybe HistoryChild-    }--historyUri :: HistoryItem -> URI-historyUri = requestUri . historyRequest--historyAncestors :: HistoryItem -> [HistoryItem]-historyAncestors i = case historyParent i of-        Nothing -> []-        Just i' -> i' : historyAncestors i'--historyDescendants :: HistoryItem -> [HistoryItem]-historyDescendants i = case historyChild i of-        Nothing                  -> []-        Just (HistoryChild i' _) -> i' : historyDescendants i'--pathItemByUri :: HistoryItem -> URI -> Maybe HistoryItem-pathItemByUri i uri = find ((uri ==) . historyUri) $-    historyAncestors i ++ [i] ++ historyDescendants i--data ClientConfig = ClientConfig-    { clientConfDefaultAction     :: (String, [CommandArg])-    , clientConfProxies           :: M.Map String Host-    , clientConfGeminators        :: [(String,(Regex,String))]-    , clientConfRenderFilter      :: Maybe String-    , clientConfPreOpt            :: PreOpt-    , clientConfLinkDescFirst     :: Bool-    , clientConfMaxLogLen         :: Int-    , clientConfMaxWrapWidth      :: Int-    , clientConfNoConfirm         :: Bool-    , clientConfVerboseConnection :: Bool-    }--defaultClientConfig :: ClientConfig-defaultClientConfig = ClientConfig ("page", []) M.empty [] Nothing PreOptPre False 1000 80 False False--data QueueItem-    = QueueURI (Maybe HistoryOrigin) URI-    | QueueHistory HistoryItem--queueUri :: QueueItem -> URI-queueUri (QueueURI _ uri)    = uri-queueUri (QueueHistory item) = historyUri item--data ClientState = ClientState-    { clientCurrent          :: Maybe HistoryItem-    , clientJumpBack         :: Maybe HistoryItem-    , clientLog              :: BStack.BStack T.Text-    , clientVisited          :: S.Set Hash-    , clientQueues           :: M.Map String [QueueItem]-    , clientActiveIdentities :: ActiveIdentities-    , clientMarks            :: Marks-    , clientSessionMarks     :: M.Map Int HistoryItem-    , clientAliases          :: Aliases-    , clientConfig           :: ClientConfig-    }--type ClientM = StateT ClientState IO--type CommandAction = HistoryItem -> ClientM ()--emptyClientState :: ClientState-emptyClientState = ClientState Nothing Nothing BStack.empty S.empty M.empty M.empty emptyMarks M.empty defaultAliases defaultClientConfig--enqueue :: String -> Maybe Int -> [QueueItem] -> ClientM ()-enqueue _ _ [] = return ()-enqueue qname after qs = modify $ \s -> s {clientQueues =-        M.alter (Just . insertInNubbedList after qs queueUri) qname $ clientQueues s}--insertInNubbedList :: Eq b => Maybe Int -> [a] -> (a -> b) -> Maybe [a] -> [a]-insertInNubbedList mn as f mbs =-    let bs = fromMaybe [] mbs-        (bs',bs'') = maybe (bs,[]) (`splitAt` bs) mn-        del as' = filter $ (`notElem` (f <$> as')) . f-    in del as bs' ++ as ++ del as bs''--dropUriFromQueue :: String -> URI -> ClientM ()-dropUriFromQueue qname uri = modify $ \s -> s { clientQueues =-        M.adjust (filter ((/= uri) . queueUri)) qname $ clientQueues s }--dropUriFromQueues :: URI -> ClientM ()-dropUriFromQueues uri = do-    qnames <- gets $ M.keys . clientQueues-    forM_ qnames (`dropUriFromQueue` uri)--modifyCConf :: (ClientConfig -> ClientConfig) -> ClientM ()-modifyCConf f = modify $ \s -> s { clientConfig = f $ clientConfig s }--main :: IO ()-main = do-    argv <- getArgs-    (opts,args) <- parseArgs argv-    when (Help `elem` opts) $ putStr usage >> exitSuccess-    when (Version `elem` opts) $ putStrLn version >> exitSuccess--    defUserDataDir <- getAppUserDataDirectory programName-    userDataDir <- canonicalizePath . fromMaybe defUserDataDir $ listToMaybe [ path | DataDir path <- opts ]-    let restrictedMode = Restricted `elem` opts--    outTerm <- hIsTerminalDevice stdout-    let ansi = NoAnsi `notElem` opts && (outTerm || Ansi `elem` opts)--    let argCommands (ScriptFile "-") = warnIOErrAlt $-            (T.unpack . T.strip <$>) . T.lines <$> T.getContents-        argCommands (ScriptFile f) = warnIOErrAlt $ (T.unpack <$>) <$> readFileLines f-        argCommands (OptCommand c) = return [c]-        argCommands _ = return []-    optCommands <- concat <$> mapM argCommands opts-    let repl = (null optCommands && Batch `notElem` opts) || Prompt `elem` opts-    let interactive = Batch `notElem` opts && (repl || Interactive `elem` opts)--    let argToUri arg = doesPathExist arg >>= \case-            True -> Just . ("file://" <>) . escapePathString <$> makeAbsolute arg-            False | Just uri <- parseUriAsAbsolute . escapeIRI $ arg -> return $ Just $ show uri-            _ -> printErrOpt ansi ("No such URI / file: " <> arg) >> return Nothing-    argCommand <- join <$> mapM argToUri (listToMaybe args)--    let initialCommands = optCommands ++ maybeToList argCommand--    let ghost = Ghost `elem` opts--    unless ghost $ do-        mkdirhier userDataDir-#ifndef WINDOWS-        setFileMode userDataDir ownerModes -- chmod 700-#endif--    let cmdHistoryPath = userDataDir </> "commandHistory"-        marksPath = userDataDir </> "marks"-        logPath = userDataDir </> "log"--    let displayInfo :: [String] -> IO ()-        displayInfo = mapM_ $ printInfoOpt ansi-        displayWarning = mapM_ $ printErrOpt ansi-        promptYN = Prompt.promptYN interactive-        callbacks = InteractionCallbacks displayInfo displayWarning waitKey promptYN-        socksProxy = maybe (const NoSocksProxy) Socks5Proxy-            (listToMaybe [ h | SocksHost h <- opts ])-            . fromMaybe "1080" $ listToMaybe [ p | SocksPort p <- opts ]--    requestContext <- initRequestContext callbacks userDataDir ghost socksProxy-    (warnings, marks) <- loadMarks marksPath-    displayWarning warnings-    let hlSettings = (HL.defaultSettings::HL.Settings ClientM)-            { HL.complete = HL.noCompletion-            , HL.historyFile = if ghost then Nothing else Just cmdHistoryPath-            }--    cLog <- BStack.fromList . reverse <$> readFileLines logPath-    let visited = S.fromList $ hash . T.unpack <$> BStack.toList cLog--    let openLog :: IO (Maybe Handle)-        openLog = ignoreIOErrAlt $ Just <$> do-            h <- openFile logPath AppendMode-            hSetBuffering h LineBuffering-            return h-        closeLog :: Maybe Handle -> IO ()-        closeLog = maybe (return ()) hClose--    (if ghost then ($ Nothing) else bracketOnError openLog closeLog) $ \logH ->-        let clientOptions = ClientOptions userDataDir interactive ansi ghost-                restrictedMode requestContext logH-            initState = emptyClientState {clientMarks = marks-                , clientLog = cLog, clientVisited = visited}-        in do-            endState <- (`execStateT` initState) . HL.runInputT hlSettings $-                lineClient clientOptions initialCommands repl-            closeLog logH-            -- |reread file rather than just writing clientLog, in case another instance has also-            -- been appending to the log.-            unless ghost . warnIOErr $ truncateToEnd (clientConfMaxLogLen $ clientConfig endState) logPath--printErrOpt :: MonadIO m => Bool -> String -> m ()-printErrOpt ansi s = liftIO . hPutStrLn stderr . applyIf ansi (withColourStr BoldRed) $ "! " <> s--printInfoOpt :: MonadIO m => Bool -> String -> m ()-printInfoOpt ansi s = liftIO . hPutStrLn stderr $ applyIf ansi withBoldStr ". " <> s--getTermSize :: IO (Int,Int)-getTermSize = do-    Size.Window height width <- fromMaybe (Size.Window (2^(30::Int)) 80) <$> Size.size-    return (height,width)--lineClient :: ClientOptions -> [String] -> Bool -> HL.InputT ClientM ()-lineClient cOpts@ClientOptions{ cOptUserDataDir = userDataDir-        , cOptInteractive = interactive, cOptAnsi = ansi, cOptGhost = ghost} initialCommands repl = do-    (liftIO . readFileLines $ userDataDir </> "diohscrc") >>= mapM_ (handleLine' . T.unpack)-    lift addToQueuesFromFiles-    mapM_ handleLine' initialCommands-    when repl lineClient'-    unless ghost $ lift appendQueuesToFiles-    where-    handleLine' :: String -> HL.InputT ClientM Bool-    handleLine' line = lift get >>= \s -> handleLine cOpts s line--    lineClient' :: HL.InputT ClientM ()-    lineClient' = do-        cmd <- lift getPrompt >>= promptLineInputT-        lift addToQueuesFromFiles-        quit <- case cmd of-            Nothing -> if interactive-                then printErrOpt ansi "Use \"quit\" to quit" >> return False-                else return True-            Just Nothing -> return True-            Just (Just line) -> handleLine' line-        unless quit lineClient'--    addToQueuesFromFiles :: ClientM ()-    addToQueuesFromFiles | ghost = return ()-        | otherwise = do-            qfs <- ignoreIOErr $ liftIO findQueueFiles-            forM_ qfs $ \(qfile, qname) -> enqueue qname Nothing <=<-                ignoreIOErr . liftIO $-                mapMaybe queueLine <$> readFileLines qfile <* removeFile qfile-            ignoreIOErr . liftIO $ removeDirectory queuesDir-        where-        findQueueFiles :: IO [(FilePath,String)]-        findQueueFiles = do-            qf <- (\e -> [(queueFile, "") | e]) <$> doesFileExist queueFile-            qfs <- ((\qn -> (queuesDir </> qn, qn)) <$>) <$> listDirectory queuesDir-            return $ qf <> qfs-        queueLine :: T.Text -> Maybe QueueItem-        queueLine s = QueueURI Nothing <$> (parseUriAsAbsolute . escapeIRI $ T.unpack s)--    appendQueuesToFiles :: ClientM ()-    appendQueuesToFiles = do-        queues <- gets $ M.toList . clientQueues-        liftIO $ createDirectoryIfMissing True queuesDir-        liftIO $ forM_ queues appendQueue-        where-        appendQueue (_, []) = pure ()-        appendQueue (qname, queue) =-            let qfile = case qname of-                    "" -> queueFile-                    s  -> queuesDir </> s-            in warnIOErr $ BL.appendFile qfile .-                T.encodeUtf8 . T.unlines $ T.pack . show . queueUri <$> queue--    queueFile, queuesDir :: FilePath-    queueFile = userDataDir </> "queue"-    queuesDir = userDataDir </> "queues"--    getPrompt :: ClientM String-    getPrompt = do-        queue <- gets $ M.findWithDefault [] "" . clientQueues-        curr <- gets clientCurrent-        proxies <- gets $ clientConfProxies . clientConfig-        ais <- gets clientActiveIdentities-        let queueStatus :: Maybe String-            queueStatus = guard (not $ null queue) >> return (show (length queue) ++ "~")-            colour = applyIf ansi . withColourStr-            bold = applyIf ansi withBoldStr-            uriStatus :: Int -> URI -> String-            uriStatus w uri =-                let fullUriStr = stripGem $ show uri-                    stripGem s = fromMaybe s $ stripPrefix "gemini://" s-                    mIdName = (identityName <$>) $ findIdentity ais =<< requestOfProxiesAndUri proxies uri-                    idStr = flip (maybe "") mIdName $ \idName ->-                        let abbrId = length idName > 8 && length fullUriStr + 2 + length idName > w - 2-                        in "[" ++ (if abbrId then ".." ++ take 6 idName else idName) ++ "]"-                    abbrUri = length fullUriStr + length idStr > w - 2-                    uriFormat = colour BoldMagenta-                    uriStr = if abbrUri-                        then-                            let abbrUriChars = w - 4 - length idStr-                                preChars = abbrUriChars `div` 2-                                postChars = abbrUriChars - preChars-                            in uriFormat (take preChars fullUriStr) <>-                            ".." <>-                            uriFormat (drop (length fullUriStr - postChars) fullUriStr)-                        else uriFormat fullUriStr-                in uriStr ++-                    (if null idStr then "" else colour Green idStr)-            prompt :: Int -> String-            prompt maxPromptWidth =-                ((applyIf ansi withReverseStr $ colour BoldCyan "%%%") ++)-                    . (" " ++) . (++ bold "> ") . unwords $ catMaybes-                    [ queueStatus-                    , uriStatus (maxPromptWidth - 5 - maybe 0 ((+1) . length) queueStatus)-                        . historyUri <$> curr-                    ]-        prompt . min 40 . (`div` 2) . snd <$> liftIO getTermSize--handleLine :: ClientOptions -> ClientState -> String -> HL.InputT ClientM Bool-handleLine cOpts@ClientOptions{ cOptAnsi = ansi } s line = handle backupHandler . catchInterrupts $ case parseCommandLine line of-    Left err -> printErrOpt ansi err >> return False-    Right (CommandLine Nothing (Just (c,_))) | c `isPrefixOf` "quit" -> return True-    Right cline -> handleCommandLine cOpts s False cline >> return False-    where-    catchInterrupts = HL.handleInterrupt (printErrOpt ansi "Interrupted." >> return False) . HL.withInterrupt . lift-    backupHandler :: SomeException -> HL.InputT ClientM Bool-    backupHandler = (>> return False) . printErrOpt ansi . ("Unhandled exception: " <>) . show--data Target-    = TargetHistory HistoryItem-    | TargetFrom HistoryOrigin URI-    | TargetIdUri String URI-    | TargetUri URI--targetUri :: Target -> URI-targetUri (TargetHistory item) = historyUri item-targetUri (TargetFrom _ uri)   = uri-targetUri (TargetIdUri _ uri)  = uri-targetUri (TargetUri uri)      = uri--targetQueueItem :: Target -> QueueItem-targetQueueItem (TargetFrom o uri)   = QueueURI (Just o) uri-targetQueueItem (TargetHistory item) = QueueHistory item-targetQueueItem i                    = QueueURI Nothing $ targetUri i--handleCommandLine :: ClientOptions -> ClientState -> Bool -> CommandLine -> ClientM ()-handleCommandLine-        cOpts@(ClientOptions userDataDir interactive ansi ghost restrictedMode requestContext logH)-        cState@(ClientState curr jumpBack cLog visited queues _ marks sessionMarks aliases-            (ClientConfig defaultAction proxies geminators renderFilter preOpt linkDescFirst maxLogLen maxWrapWidth confNoConfirm verboseConnection))-        blockGo-    = \(CommandLine mt mcas) -> case mcas of-        Just (c,args) | Just (Alias _ (CommandLine mt' mcas')) <- lookupAlias c aliases ->-            let mcas'' = (, drop 1 args) . commandArgArg <$> headMay args-                appendCArgs (c',as') = (c', (appendTail <$> as') ++ args)-                    where-                    appendTail arg@(CommandArg a' t') = case args of-                        []                   -> arg-                        (CommandArg _ t : _) -> CommandArg a' $ t' <> " " <> t-            in handleCommandLine' (mt' `mplus` mt) $-                (appendCArgs <$> mcas') `mplus` mcas''-        _ -> handleCommandLine' mt mcas--    where--    -- Remark: we handle haskell's "configurations problem" by having the below all within the scope-    -- of the ClientOptions parameter. This is nicer to my mind than the heavier approaches of-    -- simulating global variables or threading a Reader monad throughout. The downside is that this-    -- module can't be split as much as it ought to be.-    -- Similar remarks go for `GeminiProtocol.makeRequest`.--    onRestriction :: IO ()-    onRestriction = printErr "This is not allowed in restricted mode."--    doRestricted :: Monoid a => RestrictedIO a -> IO a-    doRestricted m | restrictedMode = onRestriction >> return mempty-        | otherwise = RunExternal.runRestrictedIO m--    doRestrictedAlt :: Alternative f => RestrictedIO (f a) -> IO (f a)-    doRestrictedAlt m | restrictedMode = onRestriction >> return empty-        | otherwise = RunExternal.runRestrictedIO m--    doRestrictedFilter :: (a -> RestrictedIO a) -> (a -> IO a)-    doRestrictedFilter f | restrictedMode = \a -> do-            onRestriction-            return a-        | otherwise = RunExternal.runRestrictedIO . f--    printInfo :: MonadIO m => String -> m ()-    printInfo = printInfoOpt ansi-    printErr :: MonadIO m => String -> m ()-    printErr = printErrOpt ansi--    printIOErr :: IOError -> IO ()-    printIOErr = printErr . show--    noConfirm :: Bool-    noConfirm = confNoConfirm || not interactive--    confirm :: Applicative m => m Bool -> m Bool-    confirm | noConfirm = const $ pure True-        | otherwise = id--    promptYN = Prompt.promptYN interactive--    colour :: MetaString a => Colour -> a -> a-    colour = applyIf ansi . withColourStr-    bold :: MetaString a => a -> a-    bold = applyIf ansi withBoldStr--    isVisited :: URI -> Bool-    isVisited uri = S.member (hash $ show uri) visited--    requestOfUri = requestOfProxiesAndUri proxies--    idAtUri :: ActiveIdentities -> URI -> Maybe Identity-    idAtUri ais uri = findIdentity ais =<< requestOfUri uri--    showUriRefFull :: MetaString a => Bool -> ActiveIdentities -> URI -> URIRef -> a-    showUriRefFull ansi' ais base ref = showUriFull ansi' ais (Just base) $ relativeTo ref base--    showUriFull :: MetaString a => Bool -> ActiveIdentities -> Maybe URI -> URI -> a-    showUriFull ansi' ais base uri =-        let scheme = uriScheme uri-            handled = scheme `elem` ["gemini","file"] || M.member scheme proxies-            inHistory = isJust $ curr >>= flip pathItemByUri uri-            activeId = isJust $ idAtUri ais uri-            col = if inHistory && not activeId then BoldBlue else case (isVisited uri,handled) of-                (True,True)   -> Yellow-                (False,True)  -> BoldYellow-                (True,False)  -> Red-                (False,False) -> BoldRed-            s = case base of-                Nothing -> show uri-                Just b  -> show $ relativeFrom uri b-        in fromString (applyIf ansi' (withColourStr col) s) <> case idAtUri ais uri of-            Nothing    -> ""-            Just ident -> showIdentity ansi' ident--    displayUri :: MetaString a => URI -> a-    displayUri = colour Yellow . fromString . show--    showUri :: URI -> ClientM ()-    showUri uri = do-        ais <- gets clientActiveIdentities-        liftIO . putStrLn $ showUriFull ansi ais Nothing uri--    addToLog :: URI -> ClientM ()-    addToLog uri = do-        let t = T.pack $ show uri-        modify $ \s -> s-            { clientLog = BStack.push maxLogLen t $ clientLog s-            , clientVisited = S.insert (hash $ show uri) $ clientVisited s }-        unless ghost . liftIO $ maybe (return ()) (ignoreIOErr . (`T.hPutStrLn` t)) logH--    loggedUris = catMaybes $ (parseAbsoluteUri . escapeIRI . T.unpack <$>) $ BStack.toList cLog--    expand :: String -> String-    expand = expandHelp ansi (fst <$> aliases) userDataDir--    idsPath = userDataDir </> "identities"-    savesDir = userDataDir </> "saves"-    marksDir = userDataDir </> "marks"--    historyEnv :: HistoryItem -> ClientM [(String,String)]-    historyEnv item = gets clientActiveIdentities >>= \ais -> pure $-        [ ("URI", show $ historyUri item)-        , ("MIMETYPE", showMimeType $ historyMimedData item) ] <>-        (maybe [] (identityEnvironment idsPath) . idAtUri ais $ historyUri item)--    setMark :: String -> URIWithIdName -> ClientM ()-    setMark mark uriId | markNameValid mark = do-        modify $ \s -> s { clientMarks = insertMark mark uriId $ clientMarks s }-        unless (mark `elem` tempMarks) . liftIO .-            handle printIOErr $ saveMark marksDir mark uriId-    setMark mark _ = printErr $ "Invalid mark name " ++ mark--    promptInput = if ghost then promptLine else promptLineWithHistoryFile inputHistPath-        where inputHistPath = userDataDir </> "inputHistory"--    handleCommandLine' :: Maybe PTarget -> Maybe (String, [CommandArg]) -> ClientM ()-    handleCommandLine' mt mcas = void . runMaybeT $ do-        ts <- case mt of-            Nothing -> return []-            Just pt -> either ((>> mzero) . printErr)-                (\ts -> mapM_ addTargetId ts >> return ts) $-                resolveTarget pt-        case mcas of-            Nothing -> lift $ handleBareTargets ts-            Just (s,as) -> do-                c' <- maybe (printErr (unknownCommand s) >> mzero)-                    return $ normaliseCommand s-                lift $ handleCommand ts (c',as)-        where-        unknownCommand s = "Unknown command \"" <> s <> "\". Type \"help\" for help."-        addTargetId :: Target -> MaybeT ClientM ()-        addTargetId (TargetIdUri idName uri) =-            liftIO (loadIdentity idsPath idName) >>= (\case-                (Nothing, _) -> printErr ("Bad URI: " ++ show uri) >> mzero-                (_, Nothing) -> printErr ("Unknown identity: " ++ showIdentityName ansi idName) >> mzero-                (Just req, Just ident) -> lift $ addIdentity req ident) . (requestOfUri uri,)-        addTargetId _ = return ()--    resolveTarget :: PTarget -> Either String [Target]-    resolveTarget PTargetCurr =-        (:[]) . TargetHistory <$> maybeToEither "No current location" curr--    resolveTarget PTargetJumpBack =-        (:[]) . TargetHistory <$> maybeToEither "'' mark not set" jumpBack--    resolveTarget (PTargetMark s)-        | Just n <- readMay s =-            (:[]) . TargetHistory <$> maybeToEither ("Mark not set: " <> s) (M.lookup n sessionMarks)-        | otherwise =-            (:[]) . targetOfMark <$> maybeToEither ("Unknown mark: " <> s) (lookupMark s marks)-            where-            targetOfMark (URIWithIdName uri Nothing) = TargetUri uri-            targetOfMark (URIWithIdName uri (Just idName)) = TargetIdUri idName uri--    resolveTarget (PTargetLog specs) =-        (TargetUri <$>) <$> resolveElemsSpecs "log entry" (matchPatternOn show) loggedUris specs--    resolveTarget (PTargetQueue qname specs) =-        (queueTarget <$>) <$> resolveElemsSpecs "queue item"-            (matchPatternOn $ show . queueUri) queue specs-        where-        queue = M.findWithDefault [] qname queues-        queueTarget (QueueURI Nothing uri)  = TargetUri uri-        queueTarget (QueueURI (Just o) uri) = TargetFrom o uri-        queueTarget (QueueHistory item)     = TargetHistory item--    resolveTarget (PTargetRoot base) =-        (rootOf <$>) <$> resolveTarget base-        where-        rootOf :: Target -> Target-        rootOf (TargetHistory item)                  = rootOfItem item-        rootOf (TargetFrom (HistoryOrigin item _) _) = rootOfItem item-        rootOf t                                     = t-        rootOfItem item = TargetHistory . lastDef item $ historyAncestors item--    resolveTarget (PTargetAncestors base specs) =-        concat <$> (mapM resolveAncestors =<< resolveTarget base)-        where-        resolveAncestors :: Target -> Either String [Target]-        resolveAncestors (TargetHistory item) =-            resolveAncestors' $ historyAncestors item-        resolveAncestors (TargetFrom (HistoryOrigin item _) _) =-            resolveAncestors' $ item : historyAncestors item-        resolveAncestors _ = Left "No history"-        resolveAncestors' hist = (TargetHistory <$>) <$>-            resolveElemsSpecs "ancestor" (matchPatternOn $ show . historyUri)-                hist specs--    resolveTarget (PTargetDescendants base specs) =-        concat <$> (mapM resolveDescendants =<< resolveTarget base)-        where-        resolveDescendants :: Target -> Either String [Target]-        resolveDescendants (TargetHistory item) = (TargetHistory <$>) <$>-            resolveElemsSpecs "descendant" (matchPatternOn $ show . historyUri)-                (historyDescendants item) specs-        resolveDescendants _ = Left "No history"--    resolveTarget (PTargetChild increasing noVisited base specs) =-        concat <$> (mapM resolveChild =<< resolveTarget base)-        where-        resolveChild (TargetHistory item) =-            let itemLinks = extractLinksMimed $ historyGeminatedMimedData item-                b = case historyChild item of-                    Just (HistoryChild _ (Just b')) -> b'-                    _ | increasing                  -> -1-                    _                               -> length itemLinks-                slice | increasing = zip [b+1..] $ drop (b+1) itemLinks-                    | otherwise = zip (reverse [0..b-1]) . reverse $ take b itemLinks-                linkUnvisited (_,l) = not . isVisited $ linkUri l `relativeTo` historyUri item-                slice' = applyIf noVisited (filter linkUnvisited) slice-            in resolveLinkSpecs False item slice' specs-        resolveChild _ = Left "No known links"--    resolveTarget (PTargetLinks noVisited base specs) =-        concat <$> (mapM resolveLinks =<< resolveTarget base)-        where-        resolveLinks (TargetHistory item) =-            let itemLinks = extractLinksMimed $ historyGeminatedMimedData item-            in resolveLinkSpecs noVisited item (zip [0..] itemLinks) specs-        resolveLinks _ = Left "No known links"--    resolveTarget (PTargetRef base s) =-        let makeRel r | base == PTargetCurr = r-            makeRel r@('/':_) = '.':r-            makeRel r = r-        in case parseUriReference . escapeIRI . escapeQueryPart $ makeRel s of-            Nothing -> Left $ "Failed to parse relative URI: " <> s-            Just ref -> map relTarget <$> resolveTarget base-                where-                relTarget (TargetHistory item) = TargetFrom (HistoryOrigin item Nothing) $-                    ref `relativeTo` historyUri item-                relTarget (TargetFrom o uri) = TargetFrom o $ relativeTo ref uri-                relTarget t = TargetUri . relativeTo ref $ targetUri t--    resolveTarget (PTargetAbs s) = case parseUriAsAbsolute . escapeIRI $ escapeQueryPart s of-        Nothing  -> Left $ "Failed to parse URI: " <> s-        Just uri -> return [TargetUri uri]--    resolveLinkSpecs :: Bool -> HistoryItem -> [(Int,Link)] -> ElemsSpecs -> Either String [Target]-    resolveLinkSpecs purgeVisited item slice specs =-        let isMatch s (_,l) = matchPattern s (show $ linkUri l) ||-                matchPattern s (T.unpack $ linkDescription l)-            linkTarg (n,l) =-                let uri = linkUri l `relativeTo` historyUri item-                in if purgeVisited && isVisited uri then Nothing-                    else Just $ TargetFrom (HistoryOrigin item $ Just n) uri-        in resolveElemsSpecs "link" isMatch slice specs >>= (\case-            []    -> Left "No such link"-            targs -> return targs) . mapMaybe linkTarg--    matchPattern :: String -> String -> Bool-    matchPattern patt =-        let regex = mkRegexWithOpts patt True (any isUpper patt)-        in isJust . matchRegex regex--    matchPatternOn :: (a -> String) -> String -> a -> Bool-    matchPatternOn f patt = matchPattern patt . f--    doPage :: [T.Text] -> ClientM ()-    doPage ls-        | interactive = do-            (height,width) <- liftIO getTermSize-            let pageWidth = min maxWrapWidth (width - 4)-                perPage = height - min 3 (height `div` 4)-                doCmd str = get >>= \s -> doSubCommand s True str-            printLinesPaged pageWidth width perPage doCmd ls-        | otherwise = liftIO $ mapM_ T.putStrLn ls--    parseQueueSpec :: [CommandArg] -> Maybe (String, Maybe Int)-    parseQueueSpec [] = Just ("", Nothing)-    parseQueueSpec [CommandArg a _] | Just n <- readMay a = Just ("", Just n)-    parseQueueSpec (CommandArg a _:as) | not (null a), all isAlpha a-        , Just mn <- case as of-            []                                       -> Just Nothing-            [CommandArg a' _] | Just n <- readMay a' -> Just (Just n)-            _                                        -> Nothing-        = Just (a, mn)-    parseQueueSpec _ = Nothing--    handleBareTargets :: [Target] -> ClientM ()-    handleBareTargets [] = return ()-    handleBareTargets (_:_:_) =-        printErr "Can only go to one place at a time. Try \"show\" or \"page\"?"-    handleBareTargets [TargetHistory item] = goHistory item-    handleBareTargets [TargetFrom origin uri] = goUri False (Just origin) uri-    handleBareTargets [t] = goUri False Nothing $ targetUri t---    handleCommand :: [Target] -> (String, [CommandArg]) -> ClientM ()-    handleCommand _ (c,_) | restrictedMode && notElem c (commands True) =-        printErr "Command disabled in restricted mode"-    handleCommand [] ("help", args) = case args of-        []                 -> doPage . map (T.pack . expand) $ helpText-        CommandArg s _ : _ -> doPage . map (T.pack . expand) $ helpOn s-    handleCommand [] ("commands",_) = doPage $ T.pack . expand <$> commandHelpText-        where-        commandHelpText = ["Aliases:"] ++ (showAlias <$> aliases) ++-            ["","Commands:"] ++ (('{' :) . (<> "}") <$> commands False)-        showAlias (a, Alias s _) = "{" <> a <> "}: " <> s--    handleCommand [] ("mark", []) =-        let ms = M.toAscList marks-            markLine (m, uriId) = let m' = showMinPrefix ansi (fst <$> ms) m-                in T.pack $ "'" <> m' <>-                    replicate (max 1 $ 16 - visibleLength (T.pack m')) ' ' <>-                    showUriWithId uriId-        in doPage $ markLine <$> ms-    handleCommand [] ("inventory",_) = do-        ais <- gets clientActiveIdentities-        let showNumberedUri :: Bool -> T.Text -> (Int,URI) -> T.Text-            showNumberedUri iter s (n,uri) = s <>-                (if iter && n == 1 then " "-                    else if iter && n == 2 then T.takeEnd 1 s-                    else T.pack (show n)) <>-                " " <> showUriFull ansi ais Nothing uri-            showIteratedItem s (n,item) = showNumberedUri True s (n, historyUri item)-            showNumberedItem s (n,item) = showNumberedUri False s (n, historyUri item)-            showIteratedQueueItem s (n, QueueURI _ uri) =-                showNumberedUri True s (n, uri)-            showIteratedQueueItem s (n, QueueHistory item) =-                showNumberedUri True s (n, historyUri item) <> " {fetched}"-            showJumpBack :: [T.Text]-            showJumpBack = maybeToList $ ("'' " <>) . showUriFull ansi ais Nothing . historyUri <$> jumpBack-        doPage . intercalate [""] . filter (not . null) $-            showJumpBack :-            [ showIteratedQueueItem (T.pack $ qname <> "~") <$> zip [1..] queue-                | (qname, queue) <- M.toList queues ]-            ++ [ showNumberedItem "'" <$> M.toAscList sessionMarks-            , (showIteratedItem "<" <$> zip [1..] (maybe [] (initSafe . historyAncestors) curr))-            ++ (("@  " <>) . showUriFull ansi ais Nothing . historyUri <$>-                maybeToList (curr >>= lastMay . historyAncestors))-            , showIteratedItem ">" <$> zip [1..] (maybe [] historyDescendants curr)-            ]-    handleCommand [] ("log",_) =-        let showLog (n,t) = "$" <> T.pack (show n) <> " " <> colour Yellow t-        in doPage $ showLog <$> zip [(1::Int)..] (BStack.toList cLog)-    handleCommand [] ("alias", CommandArg a _ : CommandArg _ str : _) = void . runMaybeT $ do-        c <- either ((>>mzero) . printErr) return $ parseCommand a-        when (c /= a) $ printErr ("Bad alias: " <> a) >> mzero-        cl <- either ((>>mzero) . printErr) return $ parseCommandLine str-        modify $ \s ->-                s { clientAliases = insertAlias a (Alias str cl) . deleteAlias a $ clientAliases s }-    handleCommand [] ("alias", [CommandArg a _]) =-        modify $ \s -> s { clientAliases = deleteAlias a $ clientAliases s }-    handleCommand [] ("set", []) = liftIO $ do-        let (c,args) = defaultAction-        putStrLn $ expand "{default_action}: " <> c <>-            maybe "" ((" "<>) . commandArgLiteralTail) (headMay args)-        putStrLn $ expand "{proxies}:"-        printMap showHost $ M.toAscList proxies-        putStrLn $ expand "{geminators}:"-        printMap id $ second snd <$> geminators-        putStrLn $ expand "{render_filter}: " <> fromMaybe "" renderFilter-        putStrLn $ expand "{pre_display}: " <> showPreOpt preOpt-        putStrLn $ expand "{link_desc_first}: " <> show linkDescFirst-        putStrLn $ expand "{log_length}: " <> show maxLogLen-        putStrLn $ expand "{max_wrap_width}: " <> show maxWrapWidth-        putStrLn $ expand "{no_confirm}: " <> show noConfirm-        putStrLn $ expand "{verbose_connection}: " <> show verboseConnection-        where-            printMap :: (a -> String) -> [(String,a)] -> IO ()-            printMap f as = mapM_ putStrLn $-                (\(k,e) -> "  " <> k <> " " <> f e) <$> as-    handleCommand [] ("set", CommandArg opt _ : val)-        | opt `isPrefixOf` "default_action" = case val of-            (CommandArg cmd _ : args) -> case actionOfCommand (cmd,args) of-                Just _ -> modifyCConf $ \c -> c { clientConfDefaultAction = (cmd,args) }-                Nothing -> printErr "Invalid action"-            _ -> printErr "Require value for option."-        | opt `isPrefixOf` "proxies" || opt `isPrefixOf` "proxy" = case val of-            (CommandArg scheme _ : val') ->-                let f = maybe (M.delete scheme) (M.insert scheme) $-                        parseHost . commandArgLiteralTail =<< headMay val'-                in modifyCConf $ \c -> c { clientConfProxies = f $ clientConfProxies c }-                    -- if only I'd allowed myself to use lenses, eh?-            [] -> printErr "Require mimetype to set geminator for."-        | opt `isPrefixOf` "geminators" = case val of-            (CommandArg patt _ : val') ->-                let f = maybe (filter $ (/= patt) . fst)-                        (\v -> (++ [(patt, (mkRegexWithOpts patt True True,-                            commandArgLiteralTail v))])) $-                        headMay val'-                in modifyCConf $ \c -> c { clientConfGeminators = f $ clientConfGeminators c }-            [] -> printErr "Require mimetype to set geminator for."-        | opt `isPrefixOf` "render_filter" =-            modifyCConf $ \c -> c { clientConfRenderFilter =-                commandArgLiteralTail <$> headMay val }-        | opt `isPrefixOf` "pre_display" = case val of-            [CommandArg s _] | map toLower s `isPrefixOf` "both" ->-                modifyCConf $ \c -> c { clientConfPreOpt = PreOptBoth }-            [CommandArg s _] | map toLower s `isPrefixOf` "pre" ->-                modifyCConf $ \c -> c { clientConfPreOpt = PreOptPre }-            [CommandArg s _] | map toLower s `isPrefixOf` "alt" ->-                modifyCConf $ \c -> c { clientConfPreOpt = PreOptAlt }-            _ -> printErr "Require \"both\" or \"pre\" or \"alt\" for pre_display"-        | opt `isPrefixOf` "link_desc_first" = case val of-            [CommandArg s _] | map toLower s `isPrefixOf` "true" ->-                modifyCConf $ \c -> c { clientConfLinkDescFirst = True }-            [CommandArg s _] | map toLower s `isPrefixOf` "false" ->-                modifyCConf $ \c -> c { clientConfLinkDescFirst = False }-            _ -> printErr "Require \"true\" or \"false\" as value for link_desc_first"-        | opt `isPrefixOf` "log_length" = case val of-            [CommandArg s _] | Just n <- readMay s, n >= 0 -> do-                modifyCConf $ \c -> c { clientConfMaxLogLen = n }-                modify $ \st -> st { clientLog = BStack.truncate n $ clientLog st }-            _ -> printErr "Require non-negative integer value for log_length"-        | opt `isPrefixOf` "max_wrap_width" = case val of-            [CommandArg s _] | Just n <- readMay s, n > 0 ->-                modifyCConf $ \c -> c { clientConfMaxWrapWidth = n }-            _ -> printErr "Require positive integer value for max_wrap_width"-        | opt `isPrefixOf` "no_confirm" = case val of-            [CommandArg s _] | map toLower s `isPrefixOf` "true" ->-                modifyCConf $ \c -> c { clientConfNoConfirm = True }-            [CommandArg s _] | map toLower s `isPrefixOf` "false" ->-                modifyCConf $ \c -> c { clientConfNoConfirm = False }-            _ -> printErr "Require \"true\" or \"false\" as value for no_confirm"-        | opt `isPrefixOf` "verbose_connection" = case val of-            [CommandArg s _] | map toLower s `isPrefixOf` "true" ->-                modifyCConf $ \c -> c { clientConfVerboseConnection = True }-            [CommandArg s _] | map toLower s `isPrefixOf` "false" ->-                modifyCConf $ \c -> c { clientConfVerboseConnection = False }-            _ -> printErr "Require \"true\" or \"false\" as value for verbose_connection"-        | otherwise = printErr $ "No such option \"" <> opt <> "\"."-    handleCommand [] cargs =-        case curr of-            Just item -> handleCommand [TargetHistory item] cargs-            Nothing -> printErr "No current location. Enter an URI, or type \"help\"."--    handleCommand ts ("add", args) = case parseQueueSpec args of-        Nothing          -> printErr "Bad arguments to 'add'."-        Just (qname, mn) -> enqueue qname mn $ targetQueueItem <$> ts--    handleCommand ts ("fetch", args) = case parseQueueSpec args of-        Nothing -> printErr "Bad arguments to 'fetch."-        Just (qname, mn) -> do-            -- XXX: we have to use an IORef to store the items, since-            -- CommandAction doesn't allow a return value.-            lRef <- liftIO $ newIORef []-            let add item = liftIO $ slurpItem item >> modifyIORef lRef (item:)-            forM_ ts $ \t -> case t of-                TargetHistory item -> add item-                _ -> dropUriFromQueues uri >> doRequestUri uri add-                    where uri = targetUri t-            l <- liftIO $ reverse <$> readIORef lRef-            enqueue qname mn $ QueueHistory <$> l--    handleCommand ts cargs =-        mapM_ handleTargetCommand ts-        where-        handleTargetCommand (TargetHistory item) | Just action <- actionOfCommand cargs =-            action item-        handleTargetCommand t | Just action <- actionOfCommand cargs =-            let uri = targetUri t-            in dropUriFromQueues uri >> doRequestUri uri action-        handleTargetCommand (TargetHistory item) | ("repeat",_) <- cargs =-            goUri True (recreateOrigin <$> historyParent item) $ historyUri item-        handleTargetCommand (TargetHistory item) | ("repl",_) <- cargs =-            repl (recreateOrigin <$> historyParent item) $ historyUri item-        handleTargetCommand (TargetHistory item) =-            handleUriCommand (historyUri item) cargs-        handleTargetCommand t =-            handleUriCommand (targetUri t) cargs--        recreateOrigin :: HistoryItem -> HistoryOrigin-        recreateOrigin parent = HistoryOrigin parent $ childLink =<< historyChild parent--        handleUriCommand uri ("delete",[]) = dropUriFromQueue "" uri-        handleUriCommand uri ("delete",CommandArg qname _ : _) = dropUriFromQueue qname uri-        handleUriCommand uri ("repeat",_) = goUri True Nothing uri-        handleUriCommand uri ("uri",_) = showUri uri-        handleUriCommand uri ("mark", CommandArg mark _ : _)-            | Just _ <- readMay mark :: Maybe Int = error "Bad mark for uri"-            | otherwise = do-            ais <- gets clientActiveIdentities-            let mIdName = case findIdentity ais =<< requestOfUri uri of-                    Just ident | not $ isTemporary ident -> Just $ identityName ident-                    _ -> Nothing-            setMark mark $ URIWithIdName uri mIdName-        handleUriCommand uri ("identify", args) = case requestOfUri uri of-            Nothing -> printErr "Bad URI"-            Just req -> gets ((`findIdentityRoot` req) . clientActiveIdentities) >>= \case-                Just (root,(ident,_)) | null args -> endIdentityPrompted root ident-                _ -> void . runMaybeT $ do-                    ident <- MaybeT . liftIO $ case args of-                        CommandArg idName _ : args' ->-                            let tp = case args' of-                                    CommandArg ('e':'d':_) _ : _ -> KeyEd25519-                                    _                            -> KeyRSA-                            in getIdentity interactive ansi idsPath tp idName-                        [] -> if interactive-                            then getIdentityRequesting ansi idsPath-                            else getIdentity interactive ansi idsPath KeyRSA ""-                    lift $ addIdentity req ident-        handleUriCommand uri ("browse", args) = do-            ais <- gets clientActiveIdentities-            let envir = maybe [] (identityEnvironment idsPath) .-                    idAtUri ais . setSchemeDefault $ uri-            void . liftIO . runMaybeT $ do-                cmd <- case args of-                    [] -> maybe notSet-                        (\s -> if null s then notSet else return $ parseBrowser s) =<<-                            lift (lookupEnv "BROWSER")-                        where-                        notSet = printErr "Please set $BROWSER or give a command to run" >> mzero-                        -- |based on specification for $BROWSER in 'man 1 man'-                        parseBrowser :: String -> String-                        parseBrowser = subPercentOrAppend (show uri) . takeWhile (/=':')-                    (CommandArg _ c : _) -> return $ subPercentOrAppend (show uri) c-                lift $ confirm (confirmShell "Run" cmd) >>? doRestricted $ void (runShellCmd cmd envir)-        handleUriCommand uri ("repl",_) = repl Nothing uri-        handleUriCommand uri ("query", CommandArg _ str : _) =-                    goUri True Nothing . setQuery ('?':escapeQuery str) $ uri-        handleUriCommand uri ("log",_) = addToLog uri >> dropUriFromQueues uri--        handleUriCommand _ (c,_) = printErr $ "Bad arguments to command " <> c--        repl :: Maybe HistoryOrigin -> URI -> ClientM ()-        repl origin uri = repl' where-            repl' = liftIO (join <$> promptInput ">> ") >>= \case-                Nothing -> return ()-                Just query -> do-                    goUri True origin . setQuery ('?':escapeQuery query) $ uri-                    repl'--    slurpItem :: HistoryItem -> IO ()-    slurpItem item = slurpNoisily (historyRequestTime item) . mimedBody $ historyMimedData item--    actionOnRendered :: Bool -> ([T.Text] -> ClientM ()) -> CommandAction-    actionOnRendered ansi' m item = do-        ais <- gets clientActiveIdentities-        liftIO (renderMimed ansi' (historyUri item) ais (historyGeminatedMimedData item)) >>=-            either printErr m--    actionOfCommand :: (String, [CommandArg]) -> Maybe CommandAction-    actionOfCommand (c,_) | restrictedMode && notElem c (commands True) = Nothing-    actionOfCommand ("show",_) = Just . actionOnRendered ansi $ liftIO . mapM_ T.putStrLn-    actionOfCommand ("page",_) = Just $ actionOnRendered ansi doPage-    actionOfCommand ("links",_) = Just $ \item -> do-        ais <- gets clientActiveIdentities-        let cl = childLink =<< historyChild item-            linkLine n (Link uri desc) =-                applyIf (cl == Just (n-1)) (bold "* " <>) $-                T.pack ('[' : show n ++ "] ")-                    <> showUriRefFull ansi ais (historyUri item) uri-                    <> if T.null desc then "" else " " <>-                        applyIf ansi (withColourStr Cyan) desc-        doPage . zipWith linkLine [1..] . extractLinksMimed . historyGeminatedMimedData $ item--    actionOfCommand ("mark", CommandArg mark _ : _) |-        Just n <- readMay mark :: Maybe Int = Just $ \item -> do-            liftIO $ slurpItem item-            modify $ \s -> s { clientSessionMarks = M.insert n item $ clientSessionMarks s }-    actionOfCommand ("mime",_) = Just $ liftIO . putStrLn . showMimeType . historyMimedData-    actionOfCommand ("save", []) = actionOfCommand ("save", [CommandArg "" savesDir])-    actionOfCommand ("save", CommandArg _ path : _) = Just $ \item -> liftIO . doRestricted . RestrictedIO $ do-        createDirectoryIfMissing True savesDir-        homePath <- getHomeDirectory-        let path'-                | take 2 path == "~/" = homePath </> drop 2 path-                | take 1 path == "/" || take 2 path == "./" || take 3 path == "../" = path-                | otherwise = savesDir </> path-            body = mimedBody $ historyMimedData item-            uri = historyUri item-            name = fromMaybe (fromMaybe "" $ uriRegName uri) . lastMay .-                filter (not . null) $ pathSegments uri-        handle printIOErr . void . runMaybeT $ do-            lift $ mkdirhierto path'-            isDir <- lift $ doesDirectoryExist path'-            let fullpath = if isDir then path' </> name else path'-            lift (doesDirectoryExist fullpath) >>? do-                lift . printErr $ "Path " ++ show fullpath ++ " exists and is directory"-                mzero-            lift (doesFileExist fullpath) >>?-                guard =<< lift (promptYN False $ "Overwrite " ++ show fullpath ++ "?")-            lift $ do-                putStrLn $ "Saving to " ++ fullpath-                t0 <- timeCurrentP-                BL.writeFile fullpath =<< interleaveProgress t0 body--    actionOfCommand ("!", CommandArg _ cmd : _) = Just $ \item -> do-        env <- historyEnv item-        liftIO . handle printIOErr . doRestricted .-            shellOnData noConfirm cmd userDataDir env . mimedBody $ historyMimedData item--    actionOfCommand ("view",_) = Just $ \item ->-        let mimed = historyMimedData item-            mimetype = showMimeType mimed-            body = mimedBody mimed-        in liftIO . handle printIOErr . doRestricted $ runMailcap noConfirm "view" userDataDir mimetype body-    actionOfCommand ("|", CommandArg _ cmd : _) = Just $ \item -> do-        env <- historyEnv item-        liftIO . handle printIOErr . doRestricted $-            pipeToShellLazily cmd env . mimedBody $ historyMimedData item-    actionOfCommand ("||", args) = Just $ pipeRendered ansi args-    actionOfCommand ("||-", args) = Just $ pipeRendered False args-    actionOfCommand ("cat",_) = Just $ liftIO . BL.putStr . mimedBody . historyMimedData-    actionOfCommand ("at", CommandArg _ str : _) = Just $ \item ->-        doSubCommand (cState { clientCurrent = Just item }) blockGo str-    actionOfCommand _ = Nothing--    pipeRendered :: Bool -> [CommandArg] -> CommandAction-    pipeRendered ansi' args item = (\action -> actionOnRendered ansi' action item) $ \ls -> do-        env <- historyEnv item-        liftIO . void . runMaybeT $ do-            cmd <- case args of-                [] -> maybe notSet-                    (\s -> if null s then notSet else return s) =<<-                    liftIO (lookupEnv "PAGER")-                    where-                    notSet = printErr "Please set $PAGER or give a command to run" >> mzero-                (CommandArg _ cmd : _) -> return cmd-            lift . doRestricted . pipeToShellLazily cmd env . T.encodeUtf8 $ T.unlines ls--    doSubCommand :: ClientState -> Bool -> String -> ClientM ()-    doSubCommand s block str = void . runMaybeT $ do-        cl <- either ((>>mzero) . printErr) return $ parseCommandLine str-        lift $ handleCommandLine cOpts s block cl--    setCurr :: HistoryItem -> ClientM ()-    setCurr i =-        let isJump = isNothing $ curr >>= pathItemByUri i . historyUri-        in do-            when isJump $ modify $ \s -> s { clientJumpBack = curr }-            modify $ \s -> s { clientCurrent = Just i }--    doDefault :: HistoryItem -> ClientM ()-    doDefault item =-        maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction--    goHistory :: HistoryItem -> ClientM ()-    goHistory _ | blockGo = printErr "Can't go anywhere now."-    goHistory item = do-        dropUriFromQueues uri-        showUri uri-        setCurr item-        doDefault item-        where uri = historyUri item--    goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM ()-    goUri _ _ _ | blockGo = printErr "Can't go anywhere now."-    goUri forceRequest origin uri = do-        dropUriFromQueues uri-        activeId <- gets $ isJust . (`idAtUri` uri) . clientActiveIdentities-        case curr >>= flip pathItemByUri uri of-            Just i' | not (activeId || forceRequest) -> goHistory i'-            _ -> doRequestUri uri $ \item -> do-                let updateParent i =-                        -- Lazily recursively update the links in the doubly linked list-                        let i' = i { historyParent = updateParent . updateChild i' <$> historyParent i }-                        in i'-                    updateChild i' i = i { historyChild = setChild <$> historyChild i }-                        where setChild c = c { childItem = i' }-                    glueOrigin (HistoryOrigin o l) = updateParent $ o { historyChild = Just $ HistoryChild item' l }-                    item' = item { historyParent = glueOrigin <$> origin }-                setCurr item'-                doDefault item-                liftIO $ slurpItem item--    doRequestUri :: URI -> CommandAction -> ClientM ()-    doRequestUri uri0 action = doRequestUri' 0 uri0-        where-        doRequestUri' redirs uri-            | Just req <- requestOfUri uri = addToLog uri >> doRequest redirs req-            | otherwise = printErr $ "Bad URI: " ++ displayUri uri ++ (-                    let scheme = uriScheme uri-                    in if scheme /= "gemini" && isNothing (M.lookup scheme proxies)-                    then " : No proxy set for non-gemini scheme " ++ scheme ++ "; use \"browse\"?"-                    else "")--        doRequest :: Int -> Request -> ClientM ()-        doRequest redirs _ | redirs > 5 =-            printErr "Too many redirections!"-        doRequest redirs req@(NetworkRequest _ uri) = do-            (mId, ais) <- liftIO . useActiveIdentity noConfirm ansi req =<< gets clientActiveIdentities-            modify $ \s -> s { clientActiveIdentities = ais }-            printInfo $ ">>> " ++ showUriFull ansi ais Nothing uri-            let respBuffSize = 2 ^ (15::Int) -- 32KB max cache for response stream-            liftIO (makeRequest requestContext mId respBuffSize verboseConnection req)-                `bracket` either (\_ -> return ()) (liftIO . snd) $-                either-                    (printErr . displayException)-                    (handleResponse . fst)-            where-            handleResponse :: Response -> ClientM ()-            handleResponse (Input isPass prompt) = do-                let defaultPrompt = "[" ++ (if isPass then "PASSWORD" else "INPUT") ++ "]"-                (liftIO . (join <$>) . promptInput $-                        (if null prompt then defaultPrompt else prompt) ++ " > ") >>= \case-                    Nothing -> return ()-                    Just query -> doRequestUri' redirs . setQuery ('?':escapeQuery query) $ uri--            handleResponse (Success mimedData) = doAction req mimedData--            handleResponse (Redirect isPerm to) = do-                ais <- gets clientActiveIdentities-                let uri' = to `relativeTo` uri-                    crossSite = uriRegName uri' /= uriRegName uri-                    crossScheme = uriScheme uri' /= uriScheme uri-                    crossScope = case idAtUri ais <$> [uri,uri'] of-                            [fromId,toId] -> isJust toId && fromId /= toId-                            _             -> False-                    warningStr = colour BoldRed-                proceed <- (isJust <$>) . lift . runMaybeT $ do-                    when crossSite $ guard <=< (liftIO . promptYN False) $-                        warningStr "Follow cross-site redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"-                    when crossScheme $ guard <=< (liftIO . promptYN False) $-                        warningStr "Follow cross-protocol redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"-                    when crossScope $ guard <=< (liftIO . promptYN False) $-                        warningStr "Follow redirect with identity " ++ showUriRefFull ansi ais uri to ++ warningStr "?"-                when proceed $ do-                    when (isPerm && not ghost) . mapM_ (updateMark uri') . marksWithUri uri =<< gets clientMarks-                    doRequestUri' (redirs + 1) uri'-                where updateMark uri' (mark,uriId) = do-                        conf <- confirm . liftIO . promptYN True $ "Update mark '" <> mark <> " to " <> show uri' <> " ?"-                        when conf . setMark mark $ uriId { uriIdUri = uri' }-            handleResponse (Failure code info) | 60 <= code && code <= 69 = void . runMaybeT $ do-                identity <- do-                        liftIO . putStrLn $ (case code of-                            60 -> "Server requests identification"-                            _ -> "Server rejects provided identification certificate" ++-                                (if code == 61 then " as unauthorised" else if code == 62 then " as invalid" else ""))-                            ++ if null info then "" else ": " ++ info-                        guard interactive-                        MaybeT . liftIO $ getIdentityRequesting ansi idsPath-                lift $ do-                    addIdentity req identity-                    doRequest redirs req--            handleResponse (Failure code info) =-                printErr $ "Server returns failure: " ++ show code ++ " " ++ info-            handleResponse (MalformedResponse malformation) =-                printErr $ "Malformed response from server: " ++ show malformation--        doRequest redirs (LocalFileRequest path) | redirs > 0 = printErr "Ignoring redirect to local file."-            | otherwise = void . runMaybeT $ do-                (path', mimedData) <- MaybeT . liftIO . doRestrictedAlt . RestrictedIO . warnIOErrAlt $ do-                    let detectExtension = case takeExtension path of-                            -- |certain crucial filetypes we can't rely on magic to detect:-                            s | s `elem` [".gmi", ".gem", ".gemini"] -> Just "text/gemini"-                            ".md" -> Just "text/markdown"-                            ".html" -> Just "text/html"-                            _ -> Nothing-#ifdef MAGIC-                        detectPlain "text/plain" = fromMaybe "text/plain" detectExtension-                        detectPlain s = s-                    magic <- Magic.magicOpen [Magic.MagicMimeType]-                    Magic.magicLoadDefault magic-                    s <- detectPlain <$> Magic.magicFile magic path-#else-                    let s = if "/" `isSuffixOf` path then "inode/directory"-                            else fromMaybe "application/octet-stream" detectExtension-#endif-                    case MIME.parseMIMEType $ TS.pack s of-                        Nothing -> printErr ("Failed to parse mimetype string: " <> s) >> return Nothing-                        _ | s == "inode/directory" -> Just . (slashedPath,) . MimedData gemTextMimeType .-                            T.encodeUtf8 . T.unlines .-                            ((("=> " <>) . T.pack . escapePathString) <$>) . sort <$>-                                getDirectoryContents path-                            where slashedPath | "/" `isSuffixOf` path = path-                                    | otherwise = path <> "/"-                        Just mimetype -> Just . (path,) . MimedData mimetype <$> BL.readFile path-                lift $ doAction (LocalFileRequest path') mimedData--        doAction req mimedData = do-            t0 <- liftIO timeCurrentP-            geminated <- geminate mimedData-            action $ HistoryItem req t0 mimedData geminated Nothing Nothing-            where-            -- |returns MimedData with lazy IO-            geminate :: MimedData -> ClientM MimedData-            geminate mimed =-                let geminator = lookupGeminator $ showMimeType mimed-                in liftIO . unsafeInterleaveIO $ applyGeminator geminator-                where-                lookupGeminator mimetype =-                    listToMaybe [ gem | (_, (regex, gem)) <- geminators-                        , isJust $ matchRegex regex mimetype ]-                applyGeminator Nothing = return mimed-                applyGeminator (Just cmd) =-                    printInfo ("| " <> cmd) >>-                    MimedData gemTextMimeType <$>-                        doRestrictedFilter (filterShell cmd [("URI", show $ requestUri req)]) (mimedBody mimed)--        gemTextMimeType :: MIME.Type-        gemTextMimeType = MIME.Type (MIME.Text "gemini") []---    addIdentity :: Request -> Identity -> ClientM ()-    addIdentity req identity = do-        ais <- gets clientActiveIdentities >>= liftIO . insertIdentity req identity-        modify $ \s -> s {clientActiveIdentities = ais}-    endIdentityPrompted :: Request -> Identity -> ClientM ()-    endIdentityPrompted root ident = do-        conf <- confirm $ liftIO . promptYN False $ "Stop using " ++-            (if isTemporary ident then "temporary anonymous identity" else showIdentity ansi ident) ++-            " at " ++ displayUri (requestUri root) ++ "?"-        when conf . modify $ \s ->-                s { clientActiveIdentities = deleteIdentity root $ clientActiveIdentities s }--    extractLinksMimed :: MimedData -> [Link]-    extractLinksMimed (MimedData (MIME.Type (MIME.Text "gemini") _) body) =-        extractLinks . parseGemini $ T.decodeUtf8With T.lenientDecode body-    extractLinksMimed _ = []--    renderMimed :: Bool -> URI -> ActiveIdentities -> MimedData -> IO (Either String [T.Text])-    renderMimed ansi' uri ais (MimedData mime body) = case MIME.mimeType mime of-        MIME.Text textType -> do-            let extractCharsetParam (MIME.MIMEParam "charset" v) = Just v-                extractCharsetParam _                            = Nothing-                charset = TS.unpack . fromMaybe "utf-8" . msum . map extractCharsetParam $ MIME.mimeParams mime-                isUtf8 = map toLower charset `elem` ["utf-8", "utf8"]-#ifdef ICONV-                reencoder = if isUtf8 then id else-                    convert charset "UTF-8"-#else-                reencoder = id-            unless isUtf8 . printErr $-                "Warning: Treating unsupported charset " ++ show charset ++ " as utf-8"-#endif-            (_,width) <- getTermSize-            let pageWidth = if interactive-                then min maxWrapWidth (width - 4)-                else maxWrapWidth-            let bodyText = T.decodeUtf8With T.lenientDecode $ reencoder body-                applyFilter :: [T.Text] -> IO [T.Text]-                applyFilter = case renderFilter of-                    Nothing -> return-                    Just cmd -> (T.lines . T.decodeUtf8With T.lenientDecode <$>) .-                        doRestrictedFilter (filterShell cmd []) . BL.concat . (appendNewline . T.encodeUtf8 <$>)-                        where appendNewline = (`BL.snoc` 10)-            (Right <$>) . applyFilter . (sanitiseForDisplay <$>) $ case textType of-                    "gemini" ->-                        let opts = GemRenderOpts ansi' preOpt pageWidth linkDescFirst-                        in printGemDoc opts (showUriRefFull ansi' ais uri) $ parseGemini bodyText-                    _ -> T.stripEnd <$> T.lines bodyText-        mimeType ->-            return . Left $ "No geminator for " ++ TS.unpack (MIME.showMIMEType mimeType) ++ " configured. Try \"save\", \"view\", \"!\", or \"|\"?"++module Main where++import           Control.Monad.Catch+import           Control.Monad.State++import           Data.Hash                (hash)+import           Data.Maybe+import qualified Data.Set                 as S+import qualified Data.Text.Lazy           as T+import qualified Data.Text.Lazy.IO        as T++import qualified System.Console.Haskeline as HL+import           System.Directory+import           System.Environment+import           System.Exit+import           System.FilePath+import           System.IO+++import qualified BStack+import           ClientOptions+import           ClientState+import           GeminiProtocol+import           LineClient+import           Marks+import           Mundanities+import           Opts+import           PrintFancy+import           Prompt                   hiding (promptYN)+import qualified Prompt+import           URI+import           Version++#ifndef WINDOWS+import           System.Posix.Files       (ownerModes, setFileMode)+#endif++main :: IO ()+main = do+    argv <- getArgs+    (opts,args) <- parseArgs argv+    when (Help `elem` opts) $ putStr usage >> exitSuccess+    when (Version `elem` opts) $ putStrLn version >> exitSuccess++    defUserDataDir <- getAppUserDataDirectory programName+    userDataDir <- canonicalizePath . fromMaybe defUserDataDir $ listToMaybe [ path | DataDir path <- opts ]+    let restrictedMode = Restricted `elem` opts++    outTerm <- hIsTerminalDevice stdout+    let ansi = NoAnsi `notElem` opts && (outTerm || Ansi `elem` opts)++    let argCommands (ScriptFile "-") = warnIOErrAlt $+            (T.unpack . T.strip <$>) . T.lines <$> T.getContents+        argCommands (ScriptFile f) = warnIOErrAlt $ (T.unpack <$>) <$> readFileLines f+        argCommands (OptCommand c) = return [c]+        argCommands _ = return []+    optCommands <- concat <$> mapM argCommands opts+    let repl = (null optCommands && Batch `notElem` opts) || Prompt `elem` opts+    let interactive = Batch `notElem` opts && (repl || Interactive `elem` opts)++    let argToUri arg = doesPathExist arg >>= \case+            True -> Just . ("file://" <>) . escapePathString <$> makeAbsolute arg+            False | Just uri <- parseUriAsAbsolute . escapeIRI $ arg -> return $ Just $ show uri+            _ -> printErrFancy ansi ("No such URI / file: " <> arg) >> return Nothing+    argCommand <- join <$> mapM argToUri (listToMaybe args)++    let initialCommands = optCommands ++ maybeToList argCommand++    let ghost = Ghost `elem` opts++    unless ghost $ do+        mkdirhier userDataDir+#ifndef WINDOWS+        setFileMode userDataDir ownerModes -- chmod 700+#endif++    let cmdHistoryPath = userDataDir </> "commandHistory"+        marksPath = userDataDir </> "marks"+        logPath = userDataDir </> "log"++    let displayInfo :: [String] -> IO ()+        displayInfo = mapM_ $ printInfoFancy ansi+        displayWarning = mapM_ $ printErrFancy ansi+        promptYN = Prompt.promptYN interactive+        callbacks = InteractionCallbacks displayInfo displayWarning waitKey promptYN+        socksProxy = maybe (const NoSocksProxy) Socks5Proxy+            (listToMaybe [ h | SocksHost h <- opts ])+            . fromMaybe "1080" $ listToMaybe [ p | SocksPort p <- opts ]++    requestContext <- initRequestContext callbacks userDataDir ghost socksProxy+    (warnings, marks) <- loadMarks marksPath+    displayWarning warnings+    let hlSettings = (HL.defaultSettings::HL.Settings ClientM)+            { HL.complete = HL.noCompletion+            , HL.historyFile = if ghost then Nothing else Just cmdHistoryPath+            }++    cLog <- BStack.fromList . reverse <$> readFileLines logPath+    let visited = S.fromList $ hash . T.unpack <$> BStack.toList cLog++    let openLog :: IO (Maybe Handle)+        openLog = ignoreIOErrAlt $ Just <$> do+            h <- openFile logPath AppendMode+            hSetBuffering h LineBuffering+            return h+        closeLog :: Maybe Handle -> IO ()+        closeLog = maybe (return ()) hClose++    (if ghost then ($ Nothing) else bracketOnError openLog closeLog) $ \logH ->+        let clientOptions = ClientOptions userDataDir interactive ansi ghost+                restrictedMode requestContext logH+            initState = emptyClientState {clientMarks = marks+                , clientLog = cLog, clientVisited = visited}+        in do+            endState <- (`execStateT` initState) . HL.runInputT hlSettings $+                lineClient clientOptions initialCommands repl+            closeLog logH+            -- |reread file rather than just writing clientLog, in case another instance has also+            -- been appending to the log.+            unless ghost . warnIOErr $ truncateToEnd (clientConfMaxLogLen $ clientConfig endState) logPath

@@ -42,6 +42,11 @@ # This will do a best effort translation of utf8 to ascii when rendering text: #set render_filter stdbuf -o0 uni2ascii -BPq +## Identification+# You may want to configure certain cryptographic identities to always be used+# for certain sites. e.g. if you've created an identity "astrobotany" for use+# on astrobotany.mozz.us, you may want to uncomment the following line.+#gemini://astrobotany.mozz.us identify astrobotany  ## Aliases # You can set aliases as shorthands for commands. e.g.:@@ -55,7 +60,8 @@ #alias Read ||- espeak -s 300 --stdin --stdout | aplay #alias BGRead ||- espeak -s 300 --stdin --stdout | aplay & -# For use with gemini://gemini.thegonz.net/titan-upload.sh+# Uploading with the Titan protocol:+# For use with gemini://gemini.thegonz.net/titan-upload.sh . # Invoke as "TARGET TU [FILE] [-t TOKEN]" where TARGET is a titan:// uri to  # upload an existing file (or compose one), # or as "TARGET TE [-t TOKEN]" to edit a gemini TARGET and upload the changed @@ -63,8 +69,8 @@ #alias TU br titan-upload.sh %s #alias TE ! $EDITOR %s && titan-upload.sh titan://${URI#gemini://} %s -## Identification-# You may want to configure certain cryptographic identities to always be used-# for certain sites. e.g. if you've created an identity "astrobotany" for use-# on astrobotany.mozz.us, you may want to uncomment the following line.-#gemini://astrobotany.mozz.us identify astrobotany+# Paging with gmir:+# For use with https://github.com/codesoap/gmir .+# Requires perl with the URI library (which you probably have).+# If you select a link in gmir, it will be added to the diohsc queue.+#alias GMIR !rel="$(gmir "%s")"; [ -n "$rel" ] && echo "$(perl -e 'use URI; print URI->new_abs(shift, shift)')' "$rel" "$URI") >> ~/.diohsc/queue"