{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
module Tldr.App.Handler
( handleAboutFlag
, retriveLocale
, checkLocale
, englishViewOptions
, getCheckDirs
, pageExists
, getPagePath
, updateTldrPages
, handleTldrOpts
) where
import Data.Char (toLower)
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Data.Semigroup ((<>))
import qualified Data.Set as Set
import Data.Version (showVersion)
import Data.Time.Clock
import Control.Monad (when)
import Options.Applicative
import Paths_tldr (version)
import System.Directory
( XdgDirectory(..)
, createDirectory
, removePathForcibly
, doesFileExist
, doesDirectoryExist
, getModificationTime
, getXdgDirectory
)
import System.Environment (lookupEnv, getExecutablePath)
import System.Exit (exitFailure)
import System.FilePath ((<.>), (</>))
import System.IO (hPutStrLn, stderr, stdout)
import Network.HTTP.Simple
import Codec.Archive.Zip
import Tldr
import Tldr.App.Constant
import Tldr.Types
handleAboutFlag :: IO ()
handleAboutFlag :: IO ()
handleAboutFlag = do
FilePath
path <- IO FilePath
getExecutablePath
let content :: FilePath
content =
[FilePath] -> FilePath
unlines
[ FilePath
path FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" v" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Version -> FilePath
showVersion Version
version
, FilePath
"Copyright (C) 2017 Sibi Prabakaran"
, FilePath
"Source available at https://github.com/psibi/tldr-hs"
]
FilePath -> IO ()
putStr FilePath
content
retriveLocale :: IO Locale
retriveLocale :: IO Locale
retriveLocale = do
Maybe FilePath
lang <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"LANG"
Locale -> IO Locale
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Locale -> IO Locale) -> Locale -> IO Locale
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> Locale
computeLocale Maybe FilePath
lang
checkLocale :: Locale -> Bool
checkLocale :: Locale -> Bool
checkLocale Locale
English = Bool
True
checkLocale Locale
_ = Bool
False
englishViewOptions :: ViewOptions -> ViewOptions
englishViewOptions :: ViewOptions -> ViewOptions
englishViewOptions ViewOptions
xs = ViewOptions
xs { languageOption :: Maybe FilePath
languageOption = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"en_US.utf8" }
handleTldrOpts :: TldrOpts -> IO ()
handleTldrOpts :: TldrOpts -> IO ()
handleTldrOpts opts :: TldrOpts
opts@TldrOpts {Maybe Int
Maybe ColorSetting
TldrCommand
colorSetting :: TldrOpts -> Maybe ColorSetting
autoUpdateInterval :: TldrOpts -> Maybe Int
tldrAction :: TldrOpts -> TldrCommand
colorSetting :: Maybe ColorSetting
autoUpdateInterval :: Maybe Int
tldrAction :: TldrCommand
..} =
case TldrCommand
tldrAction of
TldrCommand
UpdateIndex -> IO ()
updateTldrPages
TldrCommand
About -> IO ()
handleAboutFlag
ViewPage ViewOptions
voptions [FilePath]
pages -> do
Bool
shouldPerformUpdate <- TldrOpts -> IO Bool
updateNecessary TldrOpts
opts
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldPerformUpdate IO ()
updateTldrPages
let npage :: FilePath
npage = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"-" [FilePath]
pages
Locale
locale <-
case ViewOptions -> Maybe FilePath
languageOption ViewOptions
voptions of
Maybe FilePath
Nothing -> IO Locale
retriveLocale
Just FilePath
lg -> Locale -> IO Locale
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Locale -> IO Locale) -> Locale -> IO Locale
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> Locale
computeLocale (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
lg)
Maybe FilePath
fname <- Locale -> FilePath -> [FilePath] -> IO (Maybe FilePath)
getPagePath Locale
locale FilePath
npage (ViewOptions -> [FilePath]
getCheckDirs ViewOptions
voptions)
case Maybe FilePath
fname of
Just FilePath
path -> do
ColorSetting
defColor <- IO ColorSetting
getNoColorEnv
let color :: ColorSetting
color = ColorSetting -> Maybe ColorSetting -> ColorSetting
forall a. a -> Maybe a -> a
fromMaybe ColorSetting
defColor Maybe ColorSetting
colorSetting
FilePath -> Handle -> ColorSetting -> IO ()
renderPage FilePath
path Handle
stdout ColorSetting
color
Maybe FilePath
Nothing ->
if Locale -> Bool
checkLocale Locale
locale
then do
Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath
"No tldr entry for " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
unwords [FilePath]
pages)
IO ()
forall a. IO a
exitFailure
else TldrOpts -> IO ()
handleTldrOpts
(TldrOpts
opts
{ tldrAction :: TldrCommand
tldrAction =
ViewOptions -> [FilePath] -> TldrCommand
ViewPage (ViewOptions -> ViewOptions
englishViewOptions ViewOptions
voptions) [FilePath]
pages
})
updateNecessary :: TldrOpts -> IO Bool
updateNecessary :: TldrOpts -> IO Bool
updateNecessary TldrOpts{Maybe Int
Maybe ColorSetting
TldrCommand
colorSetting :: Maybe ColorSetting
autoUpdateInterval :: Maybe Int
tldrAction :: TldrCommand
colorSetting :: TldrOpts -> Maybe ColorSetting
autoUpdateInterval :: TldrOpts -> Maybe Int
tldrAction :: TldrOpts -> TldrCommand
..} = do
FilePath
dataDir <- XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgData FilePath
tldrDirName
Bool
dataDirExists <- FilePath -> IO Bool
doesDirectoryExist FilePath
dataDir
if Bool -> Bool
not Bool
dataDirExists
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
UTCTime
lastCachedTime <- FilePath -> IO UTCTime
getModificationTime FilePath
dataDir
UTCTime
currentTime <- IO UTCTime
getCurrentTime
let diffExceedsLimit :: a -> Bool
diffExceedsLimit a
limit
= UTCTime
currentTime UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
lastCachedTime
NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> a -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
limit NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
nominalDay
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Int -> Bool
forall a. Integral a => a -> Bool
diffExceedsLimit Maybe Int
autoUpdateInterval
updateTldrPages :: IO ()
updateTldrPages :: IO ()
updateTldrPages = do
FilePath
dataDir <- XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgData FilePath
tldrDirName
FilePath -> IO ()
removePathForcibly FilePath
dataDir
FilePath -> IO ()
createDirectory FilePath
dataDir
FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Downloading tldr pages to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dataDir
Response ByteString
response <- Request -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLBS (Request -> IO (Response ByteString))
-> Request -> IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ FilePath -> Request
parseRequest_ FilePath
pagesUrl
let zipArchive :: Archive
zipArchive = ByteString -> Archive
toArchive (ByteString -> Archive) -> ByteString -> Archive
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall a. Response a -> a
getResponseBody Response ByteString
response
[ZipOption] -> Archive -> IO ()
extractFilesFromArchive [FilePath -> ZipOption
OptDestination FilePath
dataDir] Archive
zipArchive
computeLocale :: Maybe String -> Locale
computeLocale :: Maybe FilePath -> Locale
computeLocale Maybe FilePath
lang = case (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
lang of
Maybe FilePath
Nothing -> Locale
Missing
Just (Char
'e':Char
'n':FilePath
_) -> Locale
English
Just (Char
a:Char
b:Char
'_':FilePath
_) -> FilePath -> Locale
Other [Char
a,Char
b]
Just (Char
a:Char
b:Char
c:Char
'_':FilePath
_) -> FilePath -> Locale
Other [Char
a,Char
b,Char
c]
Just FilePath
other -> FilePath -> Locale
Unknown FilePath
other
getPagePath :: Locale -> String -> [String] -> IO (Maybe FilePath)
getPagePath :: Locale -> FilePath -> [FilePath] -> IO (Maybe FilePath)
getPagePath Locale
locale FilePath
page [FilePath]
pDirs = do
FilePath
dataDir <- XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgData FilePath
tldrDirName
let currentLocale :: FilePath
currentLocale = case Locale
locale of
Locale
English -> FilePath
"pages"
Other FilePath
xs -> FilePath
"pages." FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
xs
Unknown FilePath
xs -> FilePath
"pages." FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
xs
Locale
Missing -> FilePath
"pages"
pageDir :: FilePath
pageDir = FilePath
dataDir FilePath -> FilePath -> FilePath
</> FilePath
currentLocale
paths :: [FilePath]
paths = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
x -> FilePath
pageDir FilePath -> FilePath -> FilePath
</> FilePath
x FilePath -> FilePath -> FilePath
</> FilePath
page FilePath -> FilePath -> FilePath
<.> FilePath
"md") [FilePath]
pDirs
(Maybe FilePath -> Maybe FilePath -> Maybe FilePath)
-> [Maybe FilePath] -> Maybe FilePath
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Maybe FilePath -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) ([Maybe FilePath] -> Maybe FilePath)
-> IO [Maybe FilePath] -> IO (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO (Maybe FilePath))
-> [FilePath] -> IO [Maybe FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO (Maybe FilePath)
pageExists [FilePath]
paths
pageExists :: FilePath -> IO (Maybe FilePath)
pageExists :: FilePath -> IO (Maybe FilePath)
pageExists FilePath
fname = do
Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
fname
if Bool
exists
then Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fname
else Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
getCheckDirs :: ViewOptions -> [String]
getCheckDirs :: ViewOptions -> [FilePath]
getCheckDirs ViewOptions
voptions =
case ViewOptions -> Maybe FilePath
platformOption ViewOptions
voptions of
Maybe FilePath
Nothing -> [FilePath]
checkDirs
Just FilePath
platform -> [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
nubOrd ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath
"common", FilePath
platform] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath]
checkDirs
getNoColorEnv :: IO ColorSetting
getNoColorEnv :: IO ColorSetting
getNoColorEnv = do
Maybe FilePath
noColorSet <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"NO_COLOR"
ColorSetting -> IO ColorSetting
forall (m :: * -> *) a. Monad m => a -> m a
return (ColorSetting -> IO ColorSetting)
-> ColorSetting -> IO ColorSetting
forall a b. (a -> b) -> a -> b
$ case Maybe FilePath
noColorSet of
Just FilePath
_ -> ColorSetting
NoColor
Maybe FilePath
Nothing -> ColorSetting
UseColor
nubOrd :: Ord a => [a] -> [a]
nubOrd :: [a] -> [a]
nubOrd = Set a -> [a] -> [a]
forall a. Ord a => Set a -> [a] -> [a]
loop Set a
forall a. Monoid a => a
mempty
where
loop :: Set a -> [a] -> [a]
loop Set a
_ [] = []
loop !Set a
s (a
a:[a]
as)
| a
a a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
s = Set a -> [a] -> [a]
loop Set a
s [a]
as
| Bool
otherwise = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
loop (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
a Set a
s) [a]
as