diohsc.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE CPP               #-}
  12 {-# LANGUAGE FlexibleContexts  #-}
  13 {-# LANGUAGE LambdaCase        #-}
  14 {-# LANGUAGE OverloadedStrings #-}
  15
  16 module Main where
  17
  18 import           Control.Monad.Catch
  19 import           Control.Monad.State
  20
  21 import           Data.Hashable            (hash)
  22 import           Data.Maybe
  23 import qualified Data.Set                 as S
  24 import qualified Data.Text.Lazy           as T
  25 import qualified Data.Text.Lazy.IO        as T
  26
  27 import qualified System.Console.Haskeline as HL
  28 import           System.Directory
  29 import           System.Environment
  30 import           System.Exit
  31 import           System.FilePath
  32 import           System.IO
  33
  34
  35 import qualified BStack
  36 import           ClientOptions
  37 import           ClientState
  38 import           GeminiProtocol
  39 import           LineClient
  40 import           Marks
  41 import           Mundanities
  42 import           Opts
  43 import           PrintFancy
  44 import           Prompt                   hiding (promptYN)
  45 import qualified Prompt
  46 import           URI
  47 import           Version
  48
  49 #ifndef WINDOWS
  50 import           System.Posix.Files       (ownerModes, setFileMode)
  51 #endif
  52
  53 main :: IO ()
  54 main = do
  55     argv <- getArgs
  56     (opts,args) <- parseArgs argv
  57     when (Help `elem` opts) $ putStr usage >> exitSuccess
  58     when (Version `elem` opts) $ putStrLn version >> exitSuccess
  59
  60     defUserDataDir <- getAppUserDataDirectory programName
  61     userDataDir <- canonicalizePath . fromMaybe defUserDataDir $ listToMaybe [ path | DataDir path <- opts ]
  62     let restrictedMode = Restricted `elem` opts
  63
  64     outTerm <- hIsTerminalDevice stdout
  65     let ansi = NoAnsi `notElem` opts && (outTerm || Ansi `elem` opts)
  66
  67     let argCommands (ScriptFile "-") = warnIOErrAlt $
  68             (T.unpack . T.strip <$>) . T.lines <$> T.getContents
  69         argCommands (ScriptFile f) = warnIOErrAlt $ (T.unpack <$>) <$> readFileLines f
  70         argCommands (OptCommand c) = return [c]
  71         argCommands _ = return []
  72     optCommands <- concat <$> mapM argCommands opts
  73     let repl = (null optCommands && Batch `notElem` opts) || Prompt `elem` opts
  74     let interactive = Batch `notElem` opts && (repl || Interactive `elem` opts)
  75
  76     let argToUri arg = doesPathExist arg >>= \case
  77             True -> Just . ("file://" <>) . escapePathString <$> makeAbsolute arg
  78             False | Just uri <- parseUriAsAbsolute . escapeIRI $ arg -> return $ Just $ show uri
  79             _ -> printErrFancy ansi ("No such URI / file: " <> arg) >> return Nothing
  80     argCommand <- join <$> mapM argToUri (listToMaybe args)
  81
  82     let initialCommands = optCommands ++ maybeToList argCommand
  83
  84     let ghost = Ghost `elem` opts
  85
  86     unless ghost $ do
  87         mkdirhier userDataDir
  88 #ifndef WINDOWS
  89         setFileMode userDataDir ownerModes -- chmod 700
  90 #endif
  91
  92     let cmdHistoryPath = userDataDir </> "commandHistory"
  93         marksPath = userDataDir </> "marks"
  94         logPath = userDataDir </> "log"
  95
  96     let displayInfo :: [String] -> IO ()
  97         displayInfo = mapM_ $ printInfoFancy ansi
  98         displayWarning = mapM_ $ printErrFancy ansi
  99         promptYN = Prompt.promptYN interactive
 100         callbacks = InteractionCallbacks displayInfo displayWarning waitKey promptYN
 101         socksProxy = maybe (const NoSocksProxy) Socks5Proxy
 102             (listToMaybe [ h | SocksHost h <- opts ])
 103             . fromMaybe "1080" $ listToMaybe [ p | SocksPort p <- opts ]
 104
 105     requestContext <- initRequestContext callbacks userDataDir ghost socksProxy
 106     marks <- loadMarks marksPath
 107     let hlSettings = (HL.defaultSettings::HL.Settings ClientM)
 108             { HL.complete = HL.noCompletion
 109             , HL.historyFile = if ghost then Nothing else Just cmdHistoryPath
 110             }
 111
 112     logLines <- reverse <$> readFileLines logPath
 113     let cLog = BStack.fromList logLines
 114     let visited = S.fromList $ hash <$> logLines
 115
 116     let openLog :: IO (Maybe Handle)
 117         openLog = ignoreIOErrAlt $ Just <$> do
 118             h <- openFile logPath AppendMode
 119             hSetBuffering h LineBuffering
 120             return h
 121         closeLog :: Maybe Handle -> IO ()
 122         closeLog = maybe (return ()) hClose
 123
 124     (if ghost then ($ Nothing) else bracketOnError openLog closeLog) $ \logH ->
 125         let clientOptions = ClientOptions userDataDir interactive ansi ghost
 126                 restrictedMode requestContext logH
 127             initState = emptyClientState {clientMarks = marks
 128                 , clientLog = cLog, clientVisited = visited}
 129         in do
 130             endState <- (`execStateT` initState) . HL.runInputT hlSettings $
 131                 lineClient clientOptions initialCommands repl
 132             closeLog logH
 133             -- |reread file rather than just writing clientLog, in case another instance has also
 134             -- been appending to the log.
 135             unless ghost . warnIOErr $ truncateToEnd (clientConfMaxLogLen $ clientConfig endState) logPath