{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Headroom.Template.TemplateRef
(
TemplateRef(..)
, mkTemplateRef
, renderRef
, TemplateRefError(..)
)
where
import Data.Aeson ( FromJSON(..)
, Value(String)
)
import Data.String.Interpolate ( i
, iii
)
import Headroom.Data.EnumExtra ( textToEnum )
import Headroom.Data.Regex ( match
, re
)
import Headroom.FileType.Types ( FileType(..) )
import Headroom.Types ( LicenseType
, fromHeadroomError
, toHeadroomError
)
import RIO
import qualified RIO.Text as T
import qualified Text.URI as URI
import Text.URI ( URI(..)
, mkURI
)
data TemplateRef
= InlineRef Text
| LocalTemplateRef FilePath
| UriTemplateRef URI
| BuiltInRef LicenseType FileType
deriving (TemplateRef -> TemplateRef -> Bool
(TemplateRef -> TemplateRef -> Bool)
-> (TemplateRef -> TemplateRef -> Bool) -> Eq TemplateRef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TemplateRef -> TemplateRef -> Bool
$c/= :: TemplateRef -> TemplateRef -> Bool
== :: TemplateRef -> TemplateRef -> Bool
$c== :: TemplateRef -> TemplateRef -> Bool
Eq, Eq TemplateRef
Eq TemplateRef
-> (TemplateRef -> TemplateRef -> Ordering)
-> (TemplateRef -> TemplateRef -> Bool)
-> (TemplateRef -> TemplateRef -> Bool)
-> (TemplateRef -> TemplateRef -> Bool)
-> (TemplateRef -> TemplateRef -> Bool)
-> (TemplateRef -> TemplateRef -> TemplateRef)
-> (TemplateRef -> TemplateRef -> TemplateRef)
-> Ord TemplateRef
TemplateRef -> TemplateRef -> Bool
TemplateRef -> TemplateRef -> Ordering
TemplateRef -> TemplateRef -> TemplateRef
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TemplateRef -> TemplateRef -> TemplateRef
$cmin :: TemplateRef -> TemplateRef -> TemplateRef
max :: TemplateRef -> TemplateRef -> TemplateRef
$cmax :: TemplateRef -> TemplateRef -> TemplateRef
>= :: TemplateRef -> TemplateRef -> Bool
$c>= :: TemplateRef -> TemplateRef -> Bool
> :: TemplateRef -> TemplateRef -> Bool
$c> :: TemplateRef -> TemplateRef -> Bool
<= :: TemplateRef -> TemplateRef -> Bool
$c<= :: TemplateRef -> TemplateRef -> Bool
< :: TemplateRef -> TemplateRef -> Bool
$c< :: TemplateRef -> TemplateRef -> Bool
compare :: TemplateRef -> TemplateRef -> Ordering
$ccompare :: TemplateRef -> TemplateRef -> Ordering
$cp1Ord :: Eq TemplateRef
Ord, Int -> TemplateRef -> ShowS
[TemplateRef] -> ShowS
TemplateRef -> String
(Int -> TemplateRef -> ShowS)
-> (TemplateRef -> String)
-> ([TemplateRef] -> ShowS)
-> Show TemplateRef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TemplateRef] -> ShowS
$cshowList :: [TemplateRef] -> ShowS
show :: TemplateRef -> String
$cshow :: TemplateRef -> String
showsPrec :: Int -> TemplateRef -> ShowS
$cshowsPrec :: Int -> TemplateRef -> ShowS
Show)
instance FromJSON TemplateRef where
parseJSON :: Value -> Parser TemplateRef
parseJSON = \case
String Text
s -> Parser TemplateRef
-> (TemplateRef -> Parser TemplateRef)
-> Maybe TemplateRef
-> Parser TemplateRef
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser TemplateRef
forall a. HasCallStack => String -> a
error (String -> Parser TemplateRef) -> String -> Parser TemplateRef
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s) TemplateRef -> Parser TemplateRef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe TemplateRef
forall (m :: * -> *). MonadThrow m => Text -> m TemplateRef
mkTemplateRef Text
s)
Value
other -> String -> Parser TemplateRef
forall a. HasCallStack => String -> a
error (String -> Parser TemplateRef) -> String -> Parser TemplateRef
forall a b. (a -> b) -> a -> b
$ String
"Invalid value for template reference: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
other
mkTemplateRef :: MonadThrow m
=> Text
-> m TemplateRef
mkTemplateRef :: Text -> m TemplateRef
mkTemplateRef Text
raw = case Regex -> Text -> Maybe [Text]
match [re|(^\w+):\/\/|] Text
raw of
Just (Text
_ : Text
p : [Text]
_) | Text
p Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"http", Text
"https"] -> m TemplateRef
uriTemplateRef
| Bool
otherwise -> TemplateRefError -> m TemplateRef
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TemplateRefError -> m TemplateRef)
-> TemplateRefError -> m TemplateRef
forall a b. (a -> b) -> a -> b
$ Text -> Text -> TemplateRefError
UnsupportedUriProtocol Text
p Text
raw
Maybe [Text]
_ -> TemplateRef -> m TemplateRef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TemplateRef -> m TemplateRef)
-> (Text -> TemplateRef) -> Text -> m TemplateRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TemplateRef
LocalTemplateRef (String -> TemplateRef) -> (Text -> String) -> Text -> TemplateRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> m TemplateRef) -> Text -> m TemplateRef
forall a b. (a -> b) -> a -> b
$ Text
raw
where
uriTemplateRef :: m TemplateRef
uriTemplateRef = m FileType
extractFileType m FileType -> m TemplateRef -> m TemplateRef
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> URI -> TemplateRef
UriTemplateRef (URI -> TemplateRef) -> m URI -> m TemplateRef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
mkURI Text
raw
extractFileType :: m FileType
extractFileType = case Regex -> Text -> Maybe [Text]
match [re|(\w+)\.(\w+)$|] Text
raw of
Just (Text
_ : (EnumExtra FileType => Text -> Maybe FileType
forall a. EnumExtra a => Text -> Maybe a
textToEnum @FileType -> (Just FileType
ft )) : Text
_ : [Text]
_) -> FileType -> m FileType
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileType
ft
Maybe [Text]
_ -> TemplateRefError -> m FileType
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TemplateRefError -> m FileType) -> TemplateRefError -> m FileType
forall a b. (a -> b) -> a -> b
$ Text -> TemplateRefError
UnrecognizedTemplateName Text
raw
renderRef :: TemplateRef
-> Text
renderRef :: TemplateRef -> Text
renderRef (InlineRef Text
content) = [i|<inline template '#{content}'>|]
renderRef (LocalTemplateRef String
path ) = String -> Text
T.pack String
path
renderRef (UriTemplateRef URI
uri ) = URI -> Text
URI.render URI
uri
renderRef (BuiltInRef LicenseType
lt FileType
ft ) = [i|<built-in template #{lt}/#{ft}>|]
data TemplateRefError
= UnrecognizedTemplateName Text
| UnsupportedUriProtocol Text Text
deriving (TemplateRefError -> TemplateRefError -> Bool
(TemplateRefError -> TemplateRefError -> Bool)
-> (TemplateRefError -> TemplateRefError -> Bool)
-> Eq TemplateRefError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TemplateRefError -> TemplateRefError -> Bool
$c/= :: TemplateRefError -> TemplateRefError -> Bool
== :: TemplateRefError -> TemplateRefError -> Bool
$c== :: TemplateRefError -> TemplateRefError -> Bool
Eq, Int -> TemplateRefError -> ShowS
[TemplateRefError] -> ShowS
TemplateRefError -> String
(Int -> TemplateRefError -> ShowS)
-> (TemplateRefError -> String)
-> ([TemplateRefError] -> ShowS)
-> Show TemplateRefError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TemplateRefError] -> ShowS
$cshowList :: [TemplateRefError] -> ShowS
show :: TemplateRefError -> String
$cshow :: TemplateRefError -> String
showsPrec :: Int -> TemplateRefError -> ShowS
$cshowsPrec :: Int -> TemplateRefError -> ShowS
Show)
instance Exception TemplateRefError where
displayException :: TemplateRefError -> String
displayException = TemplateRefError -> String
displayException'
toException :: TemplateRefError -> SomeException
toException = TemplateRefError -> SomeException
forall e. Exception e => e -> SomeException
toHeadroomError
fromException :: SomeException -> Maybe TemplateRefError
fromException = SomeException -> Maybe TemplateRefError
forall e. Exception e => SomeException -> Maybe e
fromHeadroomError
displayException' :: TemplateRefError -> String
displayException' :: TemplateRefError -> String
displayException' = \case
UnrecognizedTemplateName Text
raw -> [iii|
Cannot extract file type and template type from path #{raw}. Please make
sure that the path ends with '<FILE_TYPE>.<TEMPLATE_TYPE>', for example
'/path/to/haskell.mustache'.
|]
UnsupportedUriProtocol Text
protocol Text
raw -> [iii|
Protocol '#{protocol}' of in URI '#{raw}' is not supported. Make sure that
you use either HTTP or HTTPS URIs.
|]