diohsc.hs

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