From f68190900920a99286d7fcf3235c65217eb29b04 Mon Sep 17 00:00:00 2001 From: Vaclav Svejcar Date: Wed, 31 Mar 2021 19:21:43 +0200 Subject: [PATCH] [#66] Introduce Headroom.IO.Network --- headroom.cabal | 3 +- src/Headroom/IO/FileSystem.hs | 2 +- src/Headroom/IO/Network.hs | 105 +++++++++++++++++++++++++++ src/Headroom/Template/TemplateRef.hs | 6 ++ 4 files changed, 114 insertions(+), 2 deletions(-) create mode 100644 src/Headroom/IO/Network.hs diff --git a/headroom.cabal b/headroom.cabal index e0fa0de..f7ed100 100644 --- a/headroom.cabal +++ b/headroom.cabal @@ -4,7 +4,7 @@ cabal-version: 2.2 -- -- see: https://github.com/sol/hpack -- --- hash: 15e44f0979eea1408d7d0b5e7cbb1a35ccd2d348ed4e9668f6f6edf6131efada +-- hash: f870c819024dab0465f52c54b12f1cbaa2bbe15340fdbad90db4d3c64b3da3fb name: headroom version: 0.4.2.0 @@ -179,6 +179,7 @@ library Headroom.HeaderFn.Types Headroom.HeaderFn.UpdateCopyright Headroom.IO.FileSystem + Headroom.IO.Network Headroom.Meta Headroom.Meta.Version Headroom.SourceCode diff --git a/src/Headroom/IO/FileSystem.hs b/src/Headroom/IO/FileSystem.hs index 205513e..e15e3d2 100644 --- a/src/Headroom/IO/FileSystem.hs +++ b/src/Headroom/IO/FileSystem.hs @@ -3,7 +3,7 @@ {-| Module : Headroom.IO.FileSystem -Description : Operations related to files and file system +Description : File system related IO operations Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com diff --git a/src/Headroom/IO/Network.hs b/src/Headroom/IO/Network.hs new file mode 100644 index 0000000..055a5a8 --- /dev/null +++ b/src/Headroom/IO/Network.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module : Headroom.IO.Network +Description : Network related IO operations +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Module providing support to perform selected network IO operations, such as +downloading file content, etc. +-} + +module Headroom.IO.Network + ( -- * Type Aliases + DownloadContentFn + -- * Polymorphic Record + , Network(..) + , mkNetwork + -- * Network IO operations + , downloadContent + ) +where + +import Data.String.Interpolate ( iii ) +import Headroom.Types ( fromHeadroomError + , toHeadroomError + ) +import Network.HTTP.Req ( GET(GET) + , NoReqBody(NoReqBody) + , bsResponse + , defaultHttpConfig + , req + , responseBody + , runReq + , useURI + ) +import RIO +import qualified RIO.Text as T +import Text.URI ( URI ) + + +-------------------------------- TYPE ALIASES -------------------------------- + +-- | Type of a function that returns content of remote resource. +type DownloadContentFn m + = URI -- ^ /URI/ of remote resource + -> m Text -- ^ downloaded content + + +----------------------------- POLYMORPHIC RECORD ----------------------------- + +-- | Polymorphic record of functions performing network IO operations. +data Network m = Network + { nDownloadContent :: DownloadContentFn m -- ^ downloads remote content + } + + +-- | Constructs new 'Network' that performs real network /IO/ operations. +mkNetwork :: MonadIO m => Network m +mkNetwork = Network { nDownloadContent = downloadContent } + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Downloads content of remote resource as 'Text'. Note that only @http@ and +-- @https@ is supported at this moment. +downloadContent :: MonadIO m + => URI -- ^ /URI/ of remote resource + -> m Text -- ^ downloaded content +downloadContent uri = runReq defaultHttpConfig $ do + urlE <- maybe (throwM $ InvalidURL uri) pure (useURI uri) + response <- case urlE of + Left httpUrl -> req GET (fst httpUrl) NoReqBody bsResponse mempty + Right httpsUrl -> req GET (fst httpsUrl) NoReqBody bsResponse mempty + case T.decodeUtf8' $ responseBody response of + Left err -> throwM $ InvalidResponse uri (T.pack $ displayException err) + Right body -> pure body + + +--------------------------------- ERROR TYPES -------------------------------- + +-- | Error related to network operations. +data NetworkError + = InvalidResponse URI Text -- ^ error during obtaining response + | InvalidURL URI -- ^ given /URI/ is not valid + deriving (Eq, Show) + + +instance Exception NetworkError where + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError + + +displayException' :: NetworkError -> String +displayException' = \case + InvalidResponse uri reason -> + [iii|Cannot decode response for '#{uri}': #{reason}|] + InvalidURL uri -> [iii|Cannot build URL from input URI: #{uri}|] diff --git a/src/Headroom/Template/TemplateRef.hs b/src/Headroom/Template/TemplateRef.hs index 7207a04..e187a71 100644 --- a/src/Headroom/Template/TemplateRef.hs +++ b/src/Headroom/Template/TemplateRef.hs @@ -71,6 +71,12 @@ data TemplateRef = TemplateRef -- | Creates a 'TemplateRef' from given text. If the raw text appears to be -- valid URL with either @http@ or @https@ as protocol, it considers it as -- 'UriTemplateSource', otherwise it creates 'LocalTemplateSource'. +-- +-- >>> mkTemplateRef "/path/to/haskell.mustache" :: Maybe TemplateRef +-- Just (TemplateRef {trFileType = Haskell, trSource = LocalTemplateSource "/path/to/haskell.mustache"}) +-- +-- >>> mkTemplateRef "https://foo.bar/haskell.mustache" :: Maybe TemplateRef +-- Just (TemplateRef {trFileType = Haskell, trSource = UriTemplateSource (URI {uriScheme = Just "https", uriAuthority = Right (Authority {authUserInfo = Nothing, authHost = "foo.bar", authPort = Nothing}), uriPath = Just (False,"haskell.mustache" :| []), uriQuery = [], uriFragment = Nothing})}) mkTemplateRef :: MonadThrow m => Text -- ^ input text -> m TemplateRef -- ^ created 'TemplateRef' (or error)