54 lines
1.8 KiB
Haskell
54 lines
1.8 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
|
|
module Yore.Download (downloadInto) where
|
|
|
|
import Control.Exception (Exception, IOException, catch)
|
|
import Control.Monad.Trans.Except (ExceptT (..))
|
|
import Data.Maybe (fromJust)
|
|
import Data.Text (Text)
|
|
import Network.HTTP.Req hiding (queryParam)
|
|
import System.Directory (createDirectoryIfMissing)
|
|
import System.FilePath (makeRelative, takeExtension, (<.>), (</>))
|
|
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
import qualified Data.Text as Text
|
|
import qualified Data.UUID.V4 as UUID
|
|
import qualified Text.URI as URI
|
|
|
|
import Yore.Error (Error (..))
|
|
|
|
-- | Download a URL and save it to a directory.
|
|
-- Returns the path of the downloaded file relative to the directory.
|
|
downloadInto
|
|
:: FilePath
|
|
-- ^ Directory where to store the file.
|
|
-> Text
|
|
-- ^ The URL to download.
|
|
-> ExceptT Error IO FilePath
|
|
downloadInto downloadDir textUrl =
|
|
download >>= save
|
|
where
|
|
download :: ExceptT Error IO LBS.ByteString
|
|
download = toExceptT (handle @HttpException) $ do
|
|
uri <- URI.mkURI textUrl
|
|
let (url, opts) = fromJust $ useHttpsURI uri
|
|
res <- runReq defaultHttpConfig $ req GET url NoReqBody lbsResponse opts
|
|
pure $ responseBody res
|
|
|
|
save :: LBS.ByteString -> ExceptT Error IO FilePath
|
|
save contents = toExceptT (handle @IOException) $ do
|
|
let suffix = takeExtension $ Text.unpack textUrl
|
|
uuid <- UUID.nextRandom
|
|
let fullPath = downloadDir </> show uuid <.> suffix
|
|
createDirectoryIfMissing True downloadDir
|
|
LBS.writeFile fullPath contents
|
|
pure $ makeRelative downloadDir fullPath
|
|
|
|
toExceptT :: (Exception e) => (e -> Error) -> IO a -> ExceptT Error IO a
|
|
toExceptT showException f =
|
|
ExceptT $ (Right <$> f) `catch` (pure . Left . showException)
|
|
|
|
handle :: (Show e) => e -> Error
|
|
handle =
|
|
GenericError . Text.pack . show
|