diff --git a/ANSIColour.hs b/ANSIColour.hs --- a/ANSIColour.hs +++ b/ANSIColour.hs @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/ClientOptions.hs b/ClientOptions.hs new file mode 100644 --- /dev/null +++ b/ClientOptions.hs @@ -0,0 +1,26 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020-23 Martin Bays +-- +-- 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 + } diff --git a/ClientState.hs b/ClientState.hs new file mode 100644 --- /dev/null +++ b/ClientState.hs @@ -0,0 +1,71 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020-23 Martin Bays +-- +-- 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 } diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -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" diff --git a/CommandLine.hs b/CommandLine.hs --- a/CommandLine.hs +++ b/CommandLine.hs @@ -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 diff --git a/GeminiProtocol.hs b/GeminiProtocol.hs --- a/GeminiProtocol.hs +++ b/GeminiProtocol.hs @@ -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 diff --git a/History.hs b/History.hs new file mode 100644 --- /dev/null +++ b/History.hs @@ -0,0 +1,66 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020-23 Martin Bays +-- +-- 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 + _ -> [] diff --git a/LineClient.hs b/LineClient.hs new file mode 100644 --- /dev/null +++ b/LineClient.hs @@ -0,0 +1,942 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020-23 Martin Bays +-- +-- 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 \"|\"?" diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -VERSION=0.1.13 +VERSION=0.1.14 GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa diff --git a/PrintFancy.hs b/PrintFancy.hs new file mode 100644 --- /dev/null +++ b/PrintFancy.hs @@ -0,0 +1,22 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020-23 Martin Bays +-- +-- 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 diff --git a/Queue.hs b/Queue.hs new file mode 100644 --- /dev/null +++ b/Queue.hs @@ -0,0 +1,64 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020-23 Martin Bays +-- +-- 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 diff --git a/ResolveTarget.hs b/ResolveTarget.hs new file mode 100644 --- /dev/null +++ b/ResolveTarget.hs @@ -0,0 +1,163 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020-23 Martin Bays +-- +-- 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 diff --git a/RunExternal.hs b/RunExternal.hs --- a/RunExternal.hs +++ b/RunExternal.hs @@ -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 -> diff --git a/Slurp.hs b/Slurp.hs --- a/Slurp.hs +++ b/Slurp.hs @@ -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" diff --git a/Target.hs b/Target.hs new file mode 100644 --- /dev/null +++ b/Target.hs @@ -0,0 +1,32 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020-23 Martin Bays +-- +-- 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 diff --git a/TextGemini.hs b/TextGemini.hs --- a/TextGemini.hs +++ b/TextGemini.hs @@ -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] diff --git a/Version.hs b/Version.hs --- a/Version.hs +++ b/Version.hs @@ -16,4 +16,4 @@ programName = "diohsc" version :: String -version = "0.1.13" +version = "0.1.14" diff --git a/diohsc.cabal b/diohsc.cabal --- a/diohsc.cabal +++ b/diohsc.cabal @@ -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 diff --git a/diohsc.hs b/diohsc.hs --- a/diohsc.hs +++ b/diohsc.hs @@ -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 diff --git a/diohscrc.sample b/diohscrc.sample --- a/diohscrc.sample +++ b/diohscrc.sample @@ -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"