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