{-# 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
  String
path <- IO String
getExecutablePath
  let content :: String
content =
        [String] -> String
unlines
          [ String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
version
          , String
"Copyright (C) 2017 Sibi Prabakaran"
          , String
"Source available at https://github.com/psibi/tldr-hs"
          ]
  String -> IO ()
putStr String
content

retriveLocale :: IO Locale
retriveLocale :: IO Locale
retriveLocale = do
  Maybe String
lang <- String -> IO (Maybe String)
lookupEnv String
"LANG"
  Locale -> IO Locale
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Locale -> IO Locale) -> Locale -> IO Locale
forall a b. (a -> b) -> a -> b
$ Maybe String -> Locale
computeLocale Maybe String
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 = Just "en_US.utf8" }

handleTldrOpts :: TldrOpts -> IO ()
handleTldrOpts :: TldrOpts -> IO ()
handleTldrOpts opts :: TldrOpts
opts@TldrOpts {Maybe Int
Maybe ColorSetting
TldrCommand
tldrAction :: TldrCommand
autoUpdateInterval :: Maybe Int
colorSetting :: Maybe ColorSetting
tldrAction :: TldrOpts -> TldrCommand
autoUpdateInterval :: TldrOpts -> Maybe Int
colorSetting :: TldrOpts -> Maybe ColorSetting
..} =
  case TldrCommand
tldrAction of
    TldrCommand
UpdateIndex -> IO ()
updateTldrPages
    TldrCommand
About -> IO ()
handleAboutFlag
    ViewPage ViewOptions
voptions [String]
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 :: String
npage = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" [String]
pages
      Locale
locale <-
        case ViewOptions -> Maybe String
languageOption ViewOptions
voptions of
          Maybe String
Nothing -> IO Locale
retriveLocale
          Just String
lg -> Locale -> IO Locale
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Locale -> IO Locale) -> Locale -> IO Locale
forall a b. (a -> b) -> a -> b
$ Maybe String -> Locale
computeLocale (String -> Maybe String
forall a. a -> Maybe a
Just String
lg)
      Maybe String
fname <- Locale -> String -> [String] -> IO (Maybe String)
getPagePath Locale
locale String
npage (ViewOptions -> [String]
getCheckDirs ViewOptions
voptions)
      case Maybe String
fname of
        Just String
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
          String -> Handle -> ColorSetting -> IO ()
renderPage String
path Handle
stdout ColorSetting
color
        Maybe String
Nothing ->
          if Locale -> Bool
checkLocale Locale
locale
            then do
              Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"No tldr entry for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [String]
pages)
              IO ()
forall a. IO a
exitFailure
            else TldrOpts -> IO ()
handleTldrOpts
                   (TldrOpts
opts
                      { tldrAction =
                          ViewPage (englishViewOptions voptions) pages
                      })

updateNecessary :: TldrOpts -> IO Bool
updateNecessary :: TldrOpts -> IO Bool
updateNecessary TldrOpts{Maybe Int
Maybe ColorSetting
TldrCommand
tldrAction :: TldrOpts -> TldrCommand
autoUpdateInterval :: TldrOpts -> Maybe Int
colorSetting :: TldrOpts -> Maybe ColorSetting
tldrAction :: TldrCommand
autoUpdateInterval :: Maybe Int
colorSetting :: Maybe ColorSetting
..} = do
  String
dataDir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgData String
tldrDirName
  Bool
dataDirExists <- String -> IO Bool
doesDirectoryExist String
dataDir
  if Bool -> Bool
not Bool
dataDirExists
    then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    else do
      UTCTime
lastCachedTime <- String -> IO UTCTime
getModificationTime String
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 a. a -> IO a
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
  String
dataDir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgData String
tldrDirName
  String -> IO ()
removePathForcibly String
dataDir
  String -> IO ()
createDirectory String
dataDir
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Downloading tldr pages to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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
$ String -> Request
parseRequest_ String
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 [String -> ZipOption
OptDestination String
dataDir] Archive
zipArchive

computeLocale :: Maybe String -> Locale
computeLocale :: Maybe String -> Locale
computeLocale Maybe String
lang = case (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
lang of
                       Maybe String
Nothing -> Locale
Missing
                       Just (Char
'e':Char
'n':String
_) -> Locale
English
                       Just (Char
a:Char
b:Char
'_':String
_) -> String -> Locale
Other [Char
a,Char
b]
                       Just (Char
a:Char
b:Char
c:Char
'_':String
_) -> String -> Locale
Other [Char
a,Char
b,Char
c]
                       Just String
other -> String -> Locale
Unknown String
other

getPagePath :: Locale -> String -> [String] -> IO (Maybe FilePath)
getPagePath :: Locale -> String -> [String] -> IO (Maybe String)
getPagePath Locale
locale String
page [String]
pDirs = do
  String
dataDir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgData String
tldrDirName
  let currentLocale :: String
currentLocale = case Locale
locale of
                        Locale
English -> String
"pages"
                        Other String
xs -> String
"pages." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
xs
                        Unknown String
xs -> String
"pages." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
xs
                        Locale
Missing -> String
"pages"
      pageDir :: String
pageDir = String
dataDir String -> String -> String
</> String
currentLocale
      paths :: [String]
paths = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> String
pageDir String -> String -> String
</> String
x String -> String -> String
</> String
page String -> String -> String
<.> String
"md") [String]
pDirs
  (Maybe String -> Maybe String -> Maybe String)
-> [Maybe String] -> Maybe String
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) ([Maybe String] -> Maybe String)
-> IO [Maybe String] -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (Maybe String)) -> [String] -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO (Maybe String)
pageExists [String]
paths

pageExists :: FilePath -> IO (Maybe FilePath)
pageExists :: String -> IO (Maybe String)
pageExists String
fname = do
  Bool
exists <- String -> IO Bool
doesFileExist String
fname
  if Bool
exists
    then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
fname
    else Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing


getCheckDirs :: ViewOptions -> [String]
getCheckDirs :: ViewOptions -> [String]
getCheckDirs ViewOptions
voptions =
  case ViewOptions -> Maybe String
platformOption ViewOptions
voptions of
    Maybe String
Nothing -> [String]
checkDirs
    Just String
platform -> [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String
"common", String
platform] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
checkDirs

getNoColorEnv :: IO ColorSetting
getNoColorEnv :: IO ColorSetting
getNoColorEnv = do
  Maybe String
noColorSet <- String -> IO (Maybe String)
lookupEnv String
"NO_COLOR"
  ColorSetting -> IO ColorSetting
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ColorSetting -> IO ColorSetting)
-> ColorSetting -> IO ColorSetting
forall a b. (a -> b) -> a -> b
$ case Maybe String
noColorSet of
    Just String
_ -> ColorSetting
NoColor
    Maybe String
Nothing -> ColorSetting
UseColor

-- | Strip out duplicates
nubOrd :: Ord a => [a] -> [a]
nubOrd :: forall a. Ord a => [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