{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
module Hpack.Defaults (
  ensure
, Defaults(..)
#ifdef TEST
, Result(..)
, ensureFile
#endif
) where

import           Imports

import           Network.HTTP.Types
import           Network.HTTP.Client
import           Network.HTTP.Client.TLS
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Char8 as B
import           System.FilePath
import           System.Directory

import           Hpack.Syntax.Defaults

type URL = String

defaultsUrl :: Github -> URL
defaultsUrl :: Github -> [Char]
defaultsUrl Github{[Char]
[[Char]]
githubPath :: Github -> [[Char]]
githubRef :: Github -> [Char]
githubRepo :: Github -> [Char]
githubOwner :: Github -> [Char]
githubPath :: [[Char]]
githubRef :: [Char]
githubRepo :: [Char]
githubOwner :: [Char]
..} = [Char]
"https://raw.githubusercontent.com/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
githubOwner [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
githubRepo [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
githubRef [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"/" [[Char]]
githubPath

defaultsCachePath :: FilePath -> Github -> FilePath
defaultsCachePath :: [Char] -> Github -> [Char]
defaultsCachePath [Char]
dir Github{[Char]
[[Char]]
githubPath :: [[Char]]
githubRef :: [Char]
githubRepo :: [Char]
githubOwner :: [Char]
githubPath :: Github -> [[Char]]
githubRef :: Github -> [Char]
githubRepo :: Github -> [Char]
githubOwner :: Github -> [Char]
..} = [[Char]] -> [Char]
joinPath ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
  [Char]
dir [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
"defaults" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
githubOwner [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
githubRepo [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
githubRef [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
githubPath

data Result = Found | NotFound | Failed String
  deriving (Result -> Result -> Bool
(Result -> Result -> Bool)
-> (Result -> Result -> Bool) -> Eq Result
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq, Int -> Result -> [Char] -> [Char]
[Result] -> [Char] -> [Char]
Result -> [Char]
(Int -> Result -> [Char] -> [Char])
-> (Result -> [Char])
-> ([Result] -> [Char] -> [Char])
-> Show Result
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Result] -> [Char] -> [Char]
$cshowList :: [Result] -> [Char] -> [Char]
show :: Result -> [Char]
$cshow :: Result -> [Char]
showsPrec :: Int -> Result -> [Char] -> [Char]
$cshowsPrec :: Int -> Result -> [Char] -> [Char]
Show)

get :: URL -> FilePath -> IO Result
get :: [Char] -> [Char] -> IO Result
get [Char]
url [Char]
file = do
  Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
  Request
request <- [Char] -> IO Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest [Char]
url
  Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager
  case Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response of
    Status Int
200 ByteString
_ -> do
      Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True ([Char] -> [Char]
takeDirectory [Char]
file)
      [Char] -> ByteString -> IO ()
LB.writeFile [Char]
file (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response)
      Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Found
    Status Int
404 ByteString
_ -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NotFound
    Status
status -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Result
Failed ([Char] -> Result) -> [Char] -> Result
forall a b. (a -> b) -> a -> b
$ [Char]
"Error while downloading " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
url [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Status -> [Char]
formatStatus Status
status [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")")

formatStatus :: Status -> String
formatStatus :: Status -> [Char]
formatStatus (Status Int
code ByteString
message) = Int -> [Char]
forall a. Show a => a -> [Char]
show Int
code [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
B.unpack ByteString
message

ensure :: FilePath -> FilePath -> Defaults -> IO (Either String FilePath)
ensure :: [Char] -> [Char] -> Defaults -> IO (Either [Char] [Char])
ensure [Char]
userDataDir [Char]
dir = \ case
  DefaultsGithub Github
defaults -> do
    let
      url :: [Char]
url = Github -> [Char]
defaultsUrl Github
defaults
      file :: [Char]
file = [Char] -> Github -> [Char]
defaultsCachePath [Char]
userDataDir Github
defaults
    [Char] -> [Char] -> IO Result
ensureFile [Char]
file [Char]
url IO Result
-> (Result -> IO (Either [Char] [Char]))
-> IO (Either [Char] [Char])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
      Result
Found -> Either [Char] [Char] -> IO (Either [Char] [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Either [Char] [Char]
forall a b. b -> Either a b
Right [Char]
file)
      Result
NotFound -> Either [Char] [Char] -> IO (Either [Char] [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Either [Char] [Char]
forall a b. a -> Either a b
Left ([Char] -> Either [Char] [Char]) -> [Char] -> Either [Char] [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
notFound [Char]
url)
      Failed [Char]
err -> Either [Char] [Char] -> IO (Either [Char] [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Either [Char] [Char]
forall a b. a -> Either a b
Left [Char]
err)
  DefaultsLocal (Local (([Char]
dir [Char] -> [Char] -> [Char]
</>) -> [Char]
file)) -> do
    [Char] -> IO Bool
doesFileExist [Char]
file IO Bool
-> (Bool -> IO (Either [Char] [Char])) -> IO (Either [Char] [Char])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
      Bool
True -> Either [Char] [Char] -> IO (Either [Char] [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Either [Char] [Char]
forall a b. b -> Either a b
Right [Char]
file)
      Bool
False -> Either [Char] [Char] -> IO (Either [Char] [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Either [Char] [Char]
forall a b. a -> Either a b
Left ([Char] -> Either [Char] [Char]) -> [Char] -> Either [Char] [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
notFound [Char]
file)
  where
    notFound :: [Char] -> [Char]
notFound [Char]
file = [Char]
"Invalid value for \"defaults\"! File " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
file [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" does not exist!"

ensureFile :: FilePath -> URL -> IO Result
ensureFile :: [Char] -> [Char] -> IO Result
ensureFile [Char]
file [Char]
url = do
  [Char] -> IO Bool
doesFileExist [Char]
file IO Bool -> (Bool -> IO Result) -> IO Result
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
    Bool
True -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Found
    Bool
False -> [Char] -> [Char] -> IO Result
get [Char]
url [Char]
file