[#66] Introduce Headroom.IO.Network

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

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  : [email protected]

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  : [email protected]
+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}|]

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)