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

import           Network.HTTP.Types
import           Network.HTTP.Client
import           Network.HTTP.Client.TLS
import           Data.List
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 -> URL
defaultsUrl Github{URL
[URL]
githubPath :: Github -> [URL]
githubRef :: Github -> URL
githubRepo :: Github -> URL
githubOwner :: Github -> URL
githubPath :: [URL]
githubRef :: URL
githubRepo :: URL
githubOwner :: URL
..} = URL
"https://raw.githubusercontent.com/" URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
githubOwner URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
"/" URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
githubRepo URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
"/" URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
githubRef URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
"/" URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL -> [URL] -> URL
forall a. [a] -> [[a]] -> [a]
intercalate URL
"/" [URL]
githubPath

defaultsCachePath :: FilePath -> Github -> FilePath
defaultsCachePath :: URL -> Github -> URL
defaultsCachePath URL
dir Github{URL
[URL]
githubPath :: [URL]
githubRef :: URL
githubRepo :: URL
githubOwner :: URL
githubPath :: Github -> [URL]
githubRef :: Github -> URL
githubRepo :: Github -> URL
githubOwner :: Github -> URL
..} = [URL] -> URL
joinPath ([URL] -> URL) -> [URL] -> URL
forall a b. (a -> b) -> a -> b
$
  URL
dir URL -> [URL] -> [URL]
forall a. a -> [a] -> [a]
: URL
"defaults" URL -> [URL] -> [URL]
forall a. a -> [a] -> [a]
: URL
githubOwner URL -> [URL] -> [URL]
forall a. a -> [a] -> [a]
: URL
githubRepo URL -> [URL] -> [URL]
forall a. a -> [a] -> [a]
: URL
githubRef URL -> [URL] -> [URL]
forall a. a -> [a] -> [a]
: [URL]
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 -> URL -> URL
[Result] -> URL -> URL
Result -> URL
(Int -> Result -> URL -> URL)
-> (Result -> URL) -> ([Result] -> URL -> URL) -> Show Result
forall a.
(Int -> a -> URL -> URL)
-> (a -> URL) -> ([a] -> URL -> URL) -> Show a
showList :: [Result] -> URL -> URL
$cshowList :: [Result] -> URL -> URL
show :: Result -> URL
$cshow :: Result -> URL
showsPrec :: Int -> Result -> URL -> URL
$cshowsPrec :: Int -> Result -> URL -> URL
Show)

get :: URL -> FilePath -> IO Result
get :: URL -> URL -> IO Result
get URL
url URL
file = do
  Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
  Request
request <- URL -> IO Request
forall (m :: * -> *). MonadThrow m => URL -> m Request
parseRequest URL
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 -> URL -> IO ()
createDirectoryIfMissing Bool
True (URL -> URL
takeDirectory URL
file)
      URL -> ByteString -> IO ()
LB.writeFile URL
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 (URL -> Result
Failed (URL -> Result) -> URL -> Result
forall a b. (a -> b) -> a -> b
$ URL
"Error while downloading " URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
url URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
" (" URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ Status -> URL
formatStatus Status
status URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
")")

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

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

ensureFile :: FilePath -> URL -> IO Result
ensureFile :: URL -> URL -> IO Result
ensureFile URL
file URL
url = do
  URL -> IO Bool
doesFileExist URL
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 -> URL -> URL -> IO Result
get URL
url URL
file