diohsc-0.1.14: diohsc.hs

-- This file is part of Diohsc
-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
--
-- 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 #-}

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