From aa268a7ffd3af3abb71a46dee3927ff35b9da17b Mon Sep 17 00:00:00 2001 From: Vaclav Svejcar Date: Wed, 31 Mar 2021 10:55:28 +0200 Subject: [PATCH] [#66] Introduce TemplateRef --- headroom.cabal | 7 +- package.yaml | 3 + src/Headroom/Data/EnumExtra.hs | 5 +- src/Headroom/Template/TemplateRef.hs | 118 ++++++++++++++++++++++ test/Headroom/Template/MustacheSpec.hs | 1 + test/Headroom/Template/TemplateRefSpec.hs | 44 ++++++++ 6 files changed, 176 insertions(+), 2 deletions(-) create mode 100644 src/Headroom/Template/TemplateRef.hs create mode 100644 test/Headroom/Template/TemplateRefSpec.hs diff --git a/headroom.cabal b/headroom.cabal index 684f9b5..df263b8 100644 --- a/headroom.cabal +++ b/headroom.cabal @@ -4,7 +4,7 @@ cabal-version: 2.2 -- -- see: https://github.com/sol/hpack -- --- hash: cc66bffc010a623d2bba63193db0fcc17a3454845d0348c3e33104d09b7ad62d +-- hash: fad870155d9e943ea6729ce0b1fc7ab981a153d1052565d791a1ab6116685bd0 name: headroom version: 0.4.2.0 @@ -184,6 +184,7 @@ library Headroom.SourceCode Headroom.Template Headroom.Template.Mustache + Headroom.Template.TemplateRef Headroom.Types Headroom.UI Headroom.UI.Progress @@ -204,11 +205,13 @@ library , generic-data , microlens , microlens-th + , modern-uri , mtl , mustache , optparse-applicative , pcre-heavy , pcre-light + , req , rio , string-interpolate , template-haskell @@ -284,6 +287,7 @@ test-suite spec Headroom.Meta.VersionSpec Headroom.SourceCodeSpec Headroom.Template.MustacheSpec + Headroom.Template.TemplateRefSpec Headroom.TypesSpec Headroom.UI.ProgressSpec Headroom.VariablesSpec @@ -299,6 +303,7 @@ test-suite spec , base >=4.7 && <5 , headroom , hspec + , modern-uri , mtl , optparse-applicative , pcre-light diff --git a/package.yaml b/package.yaml index 036694e..08bb90e 100644 --- a/package.yaml +++ b/package.yaml @@ -68,10 +68,12 @@ library: - generic-data - microlens - microlens-th + - modern-uri - mtl - mustache - pcre-light - pcre-heavy + - req - string-interpolate - template-haskell - time @@ -85,6 +87,7 @@ tests: - aeson - headroom - hspec + - modern-uri - mtl - pcre-light - QuickCheck diff --git a/src/Headroom/Data/EnumExtra.hs b/src/Headroom/Data/EnumExtra.hs index de607c1..5ac6ac5 100644 --- a/src/Headroom/Data/EnumExtra.hs +++ b/src/Headroom/Data/EnumExtra.hs @@ -16,7 +16,10 @@ Provides extra functionality for enum-like types, e.g. reading/writing from/to textual representation, etc. -} -module Headroom.Data.EnumExtra where +module Headroom.Data.EnumExtra + ( EnumExtra(..) + ) +where import RIO import qualified RIO.List as L diff --git a/src/Headroom/Template/TemplateRef.hs b/src/Headroom/Template/TemplateRef.hs new file mode 100644 index 0000000..7207a04 --- /dev/null +++ b/src/Headroom/Template/TemplateRef.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +{-| +Module : Headroom.Template.TemplateRef +Description : Representation of reference to template file +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +'TemplateRef' data type represents reference to template file, either local or +remote, which can be later opened/downloaded and parsed into template. +-} + +module Headroom.Template.TemplateRef + ( -- * Data Types + TemplateSource(..) + , TemplateRef(..) + -- * Constructor Functions + , mkTemplateRef + -- * Error Types + , TemplateRefError(..) + ) +where + +import Data.String.Interpolate ( iii ) +import Headroom.Data.EnumExtra ( textToEnum ) +import Headroom.Data.Regex ( match + , re + ) +import Headroom.FileType.Types ( FileType ) +import Headroom.Meta ( TemplateType ) +import Headroom.Template ( Template(..) ) +import Headroom.Types ( fromHeadroomError + , toHeadroomError + ) +import RIO +import qualified RIO.Text as T +import Text.URI ( URI(..) + , mkURI + ) + + +--------------------------------- DATA TYPES --------------------------------- + +-- | Source of the template (e.g. local file, URI address). +data TemplateSource + = LocalTemplateSource FilePath -- ^ template path on local file system + | UriTemplateSource URI -- ^ remote template URI adress + deriving (Eq, Show) + + +-- | Reference to the template. Later this reference is used to get and parse +-- the content of the actual template. +data TemplateRef = TemplateRef + { trFileType :: FileType -- ^ type of files which this template is for + , trSource :: TemplateSource -- ^ source of the template + } + deriving (Eq, Show) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | 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 :: MonadThrow m + => Text -- ^ input text + -> m TemplateRef -- ^ created 'TemplateRef' (or error) +mkTemplateRef raw = do + fileType <- extractFileType + source <- detectSource + pure TemplateRef { trFileType = fileType, trSource = source } + where + exts = templateExtensions @TemplateType + detectSource = case match [re|(^\w+):\/\/|] raw of + Just (_ : p : _) + | p `elem` ["http", "https"] -> UriTemplateSource <$> mkURI raw + | otherwise -> throwM $ UnsupportedUriProtocol p raw + _ -> pure . LocalTemplateSource . T.unpack $ raw + extractFileType = case match [re|(\w+)\.(\w+)$|] raw of + Just (_ : (textToEnum -> (Just ft )) : e : _) | e `elem` exts -> pure ft + _ -> throwM $ UnrecognizedTemplateName raw + + +--------------------------------- ERROR TYPES -------------------------------- + +-- | Error related to template references. +data TemplateRefError + = UnrecognizedTemplateName Text -- ^ not a valid format for template name + | UnsupportedUriProtocol Text Text -- ^ URI protocol not supported + deriving (Eq, Show) + + +instance Exception TemplateRefError where + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError + + +displayException' :: TemplateRefError -> String +displayException' = \case + UnrecognizedTemplateName raw -> [iii| + Cannot extract file type and template type from path #{raw}. Please make + sure that the path ends with '.', for example + '/path/to/haskell.mustache'. + |] + UnsupportedUriProtocol protocol raw -> [iii| + Protocol '#{protocol}' of in URI '#{raw}' is not supported. Make sure that + you use either HTTP or HTTPS URIs. + |] diff --git a/test/Headroom/Template/MustacheSpec.hs b/test/Headroom/Template/MustacheSpec.hs index 3928956..c5863d6 100644 --- a/test/Headroom/Template/MustacheSpec.hs +++ b/test/Headroom/Template/MustacheSpec.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} + module Headroom.Template.MustacheSpec ( spec ) diff --git a/test/Headroom/Template/TemplateRefSpec.hs b/test/Headroom/Template/TemplateRefSpec.hs new file mode 100644 index 0000000..09fa26f --- /dev/null +++ b/test/Headroom/Template/TemplateRefSpec.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Headroom.Template.TemplateRefSpec + ( spec + ) +where + + +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Template.TemplateRef +import RIO +import Test.Hspec +import Text.URI.QQ ( uri ) + + +spec :: Spec +spec = do + + describe "mkTemplateRef" $ do + it "creates valid reference to local Haskell template" $ do + let raw = "/path/to/some/haskell.mustache" + expected = TemplateRef + { trFileType = Haskell + , trSource = LocalTemplateSource "/path/to/some/haskell.mustache" + } + mkTemplateRef raw `shouldBe` Just expected + + it "creates valid reference to HTTP Haskell template" $ do + let raw = "http://foo/haskell.mustache" + expected = TemplateRef + { trFileType = Haskell + , trSource = UriTemplateSource [uri|http://foo/haskell.mustache|] + } + mkTemplateRef raw `shouldBe` Just expected + + it "throws error if URI is valid but protocol is not supported" $ do + let raw = "foo://foo/haskell.mustache" + mkTemplateRef raw `shouldThrow` \case + (UnsupportedUriProtocol _ _) -> True + _ -> False +