{-# 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

-- | Strip out duplicates
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