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     (warnings, marks) <- loadMarks marksPath
 107     displayWarning warnings
 108     let hlSettings = (HL.defaultSettings::HL.Settings ClientM)
 109             { HL.complete = HL.noCompletion
 110             , HL.historyFile = if ghost then Nothing else Just cmdHistoryPath
 111             }
 112
 113     logLines <- reverse <$> readFileLines logPath
 114     let cLog = BStack.fromList logLines
 115     let visited = S.fromList $ hash <$> logLines
 116
 117     let openLog :: IO (Maybe Handle)
 118         openLog = ignoreIOErrAlt $ Just <$> do
 119             h <- openFile logPath AppendMode
 120             hSetBuffering h LineBuffering
 121             return h
 122         closeLog :: Maybe Handle -> IO ()
 123         closeLog = maybe (return ()) hClose
 124
 125     (if ghost then ($ Nothing) else bracketOnError openLog closeLog) $ \logH ->
 126         let clientOptions = ClientOptions userDataDir interactive ansi ghost
 127                 restrictedMode requestContext logH
 128             initState = emptyClientState {clientMarks = marks
 129                 , clientLog = cLog, clientVisited = visited}
 130         in do
 131             endState <- (`execStateT` initState) . HL.runInputT hlSettings $
 132                 lineClient clientOptions initialCommands repl
 133             closeLog logH
 134             -- |reread file rather than just writing clientLog, in case another instance has also
 135             -- been appending to the log.
 136             unless ghost . warnIOErr $ truncateToEnd (clientConfMaxLogLen $ clientConfig endState) logPath