{-# LANGUAGE CPP                 #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}

module Dhall.Import.Headers
    ( normalizeHeaders
    , originHeadersTypeExpr
    , toHeaders
    , toOriginHeaders
    ) where

import Control.Applicative
    ( Alternative (..)
#if !MIN_VERSION_base(4,18,0)
    , liftA2
#endif
    )
import Control.Exception   (SomeException)
import Control.Monad.Catch (handle, throwM)
import Data.Text           (Text)
import Data.Void           (Void)
import Dhall.Core          (Chunks (..), Expr (..))
import Dhall.Import.Types  (HTTPHeader, OriginHeaders)
import Dhall.Parser        (Src (..))

import qualified Data.CaseInsensitive
import qualified Data.Foldable
import qualified Data.HashMap.Strict   as HashMap
import qualified Data.Text.Encoding
import qualified Dhall.Core            as Core
import qualified Dhall.Map
import qualified Dhall.Pretty.Internal
import qualified Dhall.TypeCheck

-- | Given a well-typed (of type `List { header : Text, value Text }` or
-- `List { mapKey : Text, mapValue Text }`) headers expressions in normal form
-- construct the corresponding binary http headers; otherwise return the empty
-- list.
toHeaders :: Expr s a -> [HTTPHeader]
toHeaders :: forall s a. Expr s a -> [HTTPHeader]
toHeaders (ListLit Maybe (Expr s a)
_ Seq (Expr s a)
hs) = Seq HTTPHeader -> [HTTPHeader]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList (Maybe (Seq HTTPHeader) -> Seq HTTPHeader
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
Data.Foldable.fold Maybe (Seq HTTPHeader)
maybeHeaders)
  where
      maybeHeaders :: Maybe (Seq HTTPHeader)
maybeHeaders = (Expr s a -> Maybe HTTPHeader)
-> Seq (Expr s a) -> Maybe (Seq HTTPHeader)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Seq a -> m (Seq b)
mapM Expr s a -> Maybe HTTPHeader
forall s a. Expr s a -> Maybe HTTPHeader
toHeader Seq (Expr s a)
hs
toHeaders Expr s a
_ = []

toHeader :: Expr s a -> Maybe HTTPHeader
toHeader :: forall s a. Expr s a -> Maybe HTTPHeader
toHeader (RecordLit Map Text (RecordField s a)
m) = do
    (RecordField s a -> Expr s a
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> TextLit (Chunks [] Text
keyText), RecordField s a -> Expr s a
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> TextLit (Chunks [] Text
valueText))
        <- Maybe (RecordField s a, RecordField s a)
lookupHeader Maybe (RecordField s a, RecordField s a)
-> Maybe (RecordField s a, RecordField s a)
-> Maybe (RecordField s a, RecordField s a)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (RecordField s a, RecordField s a)
lookupMapKey
    let keyBytes :: ByteString
keyBytes   = Text -> ByteString
Data.Text.Encoding.encodeUtf8 Text
keyText
    let valueBytes :: ByteString
valueBytes = Text -> ByteString
Data.Text.Encoding.encodeUtf8 Text
valueText
    HTTPHeader -> Maybe HTTPHeader
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
Data.CaseInsensitive.mk ByteString
keyBytes, ByteString
valueBytes)
      where
        lookupHeader :: Maybe (RecordField s a, RecordField s a)
lookupHeader = (RecordField s a
 -> RecordField s a -> (RecordField s a, RecordField s a))
-> Maybe (RecordField s a)
-> Maybe (RecordField s a)
-> Maybe (RecordField s a, RecordField s a)
forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Text
"header" Map Text (RecordField s a)
m) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Text
"value" Map Text (RecordField s a)
m)
        lookupMapKey :: Maybe (RecordField s a, RecordField s a)
lookupMapKey = (RecordField s a
 -> RecordField s a -> (RecordField s a, RecordField s a))
-> Maybe (RecordField s a)
-> Maybe (RecordField s a)
-> Maybe (RecordField s a, RecordField s a)
forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Text
"mapKey" Map Text (RecordField s a)
m) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Text
"mapValue" Map Text (RecordField s a)
m)
toHeader Expr s a
_ =
    Maybe HTTPHeader
forall a. Maybe a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Normalize, typecheck and return OriginHeaders from a given expression.
toOriginHeaders :: Expr Src Void -> IO OriginHeaders
toOriginHeaders :: Expr Src X -> IO OriginHeaders
toOriginHeaders Expr Src X
expr = (Expr Src X -> OriginHeaders)
-> IO (Expr Src X) -> IO OriginHeaders
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr Src X -> OriginHeaders
forall s a. Expr s a -> OriginHeaders
convert (Expr Src X -> IO (Expr Src X)
normalizeOriginHeaders Expr Src X
expr)
  where
    convert :: Expr s a -> OriginHeaders
    convert :: forall s a. Expr s a -> OriginHeaders
convert (ListLit Maybe (Expr s a)
_ Seq (Expr s a)
hs) = [(Text, [HTTPHeader])] -> OriginHeaders
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList (Seq (Expr s a) -> [(Text, [HTTPHeader])]
forall {t :: * -> *} {s} {a}.
(Monoid (t (Text, [HTTPHeader])), Traversable t) =>
t (Expr s a) -> [(Text, [HTTPHeader])]
originPairs Seq (Expr s a)
hs)
    convert Expr s a
_ = OriginHeaders
forall a. Monoid a => a
mempty

    originPairs :: t (Expr s a) -> [(Text, [HTTPHeader])]
originPairs t (Expr s a)
hs = t (Text, [HTTPHeader]) -> [(Text, [HTTPHeader])]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList (Maybe (t (Text, [HTTPHeader])) -> t (Text, [HTTPHeader])
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
Data.Foldable.fold ((Expr s a -> Maybe (Text, [HTTPHeader]))
-> t (Expr s a) -> Maybe (t (Text, [HTTPHeader]))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM Expr s a -> Maybe (Text, [HTTPHeader])
forall s a. Expr s a -> Maybe (Text, [HTTPHeader])
toOriginPair t (Expr s a)
hs))

    toOriginPair :: Expr s a -> Maybe (Text, [HTTPHeader])
    toOriginPair :: forall s a. Expr s a -> Maybe (Text, [HTTPHeader])
toOriginPair (RecordLit Map Text (RecordField s a)
m) = do
      (RecordField s a -> Expr s a
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> TextLit (Chunks [] Text
keyText), RecordField s a -> Expr s a
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Expr s a
value)
          <- Maybe (RecordField s a, RecordField s a)
lookupMapKey
      (Text, [HTTPHeader]) -> Maybe (Text, [HTTPHeader])
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
keyText, Expr s a -> [HTTPHeader]
forall s a. Expr s a -> [HTTPHeader]
toHeaders Expr s a
value)
        where
          lookupMapKey :: Maybe (RecordField s a, RecordField s a)
lookupMapKey = (RecordField s a
 -> RecordField s a -> (RecordField s a, RecordField s a))
-> Maybe (RecordField s a)
-> Maybe (RecordField s a)
-> Maybe (RecordField s a, RecordField s a)
forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Text
"mapKey" Map Text (RecordField s a)
m) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Text
"mapValue" Map Text (RecordField s a)
m)
    toOriginPair Expr s a
_ = Maybe (Text, [HTTPHeader])
forall a. Maybe a
Nothing

makeHeadersTypeExpr :: Text -> Text -> Expr Src Void
makeHeadersTypeExpr :: Text -> Text -> Expr Src X
makeHeadersTypeExpr Text
keyKey Text
valueKey =
  Expr Src X -> Expr Src X -> Expr Src X
forall s a. Expr s a -> Expr s a -> Expr s a
App Expr Src X
forall s a. Expr s a
List
      ( Map Text (RecordField Src X) -> Expr Src X
forall s a. Map Text (RecordField s a) -> Expr s a
Record (Map Text (RecordField Src X) -> Expr Src X)
-> Map Text (RecordField Src X) -> Expr Src X
forall a b. (a -> b) -> a -> b
$ Expr Src X -> RecordField Src X
forall s a. Expr s a -> RecordField s a
Core.makeRecordField (Expr Src X -> RecordField Src X)
-> Map Text (Expr Src X) -> Map Text (RecordField Src X)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          [(Text, Expr Src X)] -> Map Text (Expr Src X)
forall k v. Ord k => [(k, v)] -> Map k v
Dhall.Map.fromList
              [ (Text
keyKey, Expr Src X
forall s a. Expr s a
Text)
              , (Text
valueKey, Expr Src X
forall s a. Expr s a
Text)
              ]
      )

headersTypeExpr :: Expr Src Void
headersTypeExpr :: Expr Src X
headersTypeExpr = Text -> Text -> Expr Src X
makeHeadersTypeExpr Text
"mapKey" Text
"mapValue"

leagacyHeadersTypeExpr :: Expr Src Void
leagacyHeadersTypeExpr :: Expr Src X
leagacyHeadersTypeExpr = Text -> Text -> Expr Src X
makeHeadersTypeExpr Text
"header" Text
"value"

originHeadersTypeExpr :: Expr Src Void
originHeadersTypeExpr :: Expr Src X
originHeadersTypeExpr =
  Expr Src X -> Expr Src X -> Expr Src X
forall s a. Expr s a -> Expr s a -> Expr s a
App Expr Src X
forall s a. Expr s a
List
      ( Map Text (RecordField Src X) -> Expr Src X
forall s a. Map Text (RecordField s a) -> Expr s a
Record (Map Text (RecordField Src X) -> Expr Src X)
-> Map Text (RecordField Src X) -> Expr Src X
forall a b. (a -> b) -> a -> b
$ Expr Src X -> RecordField Src X
forall s a. Expr s a -> RecordField s a
Core.makeRecordField (Expr Src X -> RecordField Src X)
-> Map Text (Expr Src X) -> Map Text (RecordField Src X)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          [(Text, Expr Src X)] -> Map Text (Expr Src X)
forall k v. Ord k => [(k, v)] -> Map k v
Dhall.Map.fromList
              [ (Text
"mapKey", Expr Src X
forall s a. Expr s a
Text)
              , (Text
"mapValue", Expr Src X
headersTypeExpr)
              ]
      )

typecheck :: Expr Src Void -> Expr Src Void -> IO (Expr Src Void)
typecheck :: Expr Src X -> Expr Src X -> IO (Expr Src X)
typecheck Expr Src X
expected Expr Src X
expr = do
    let suffix_ :: Text
suffix_ = Expr Src X -> Text
forall a. Pretty a => a -> Text
Dhall.Pretty.Internal.prettyToStrictText Expr Src X
expected
    let annot :: Expr Src X
annot = case Expr Src X
expr of
            Note (Src SourcePos
begin SourcePos
end Text
bytes) Expr Src X
_ ->
                Src -> Expr Src X -> Expr Src X
forall s a. s -> Expr s a -> Expr s a
Note (SourcePos -> SourcePos -> Text -> Src
Src SourcePos
begin SourcePos
end Text
bytes') (Expr Src X -> Expr Src X -> Expr Src X
forall s a. Expr s a -> Expr s a -> Expr s a
Annot Expr Src X
expr Expr Src X
expected)
              where
                bytes' :: Text
bytes' = Text
bytes Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suffix_
            Expr Src X
_ ->
                Expr Src X -> Expr Src X -> Expr Src X
forall s a. Expr s a -> Expr s a -> Expr s a
Annot Expr Src X
expr Expr Src X
expected

    ()
_ <- case (Expr Src X -> Either (TypeError Src X) (Expr Src X)
forall s. Expr s X -> Either (TypeError s X) (Expr s X)
Dhall.TypeCheck.typeOf Expr Src X
annot) of
        Left TypeError Src X
err -> TypeError Src X -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM TypeError Src X
err
        Right Expr Src X
_  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Expr Src X -> IO (Expr Src X)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Src X -> Expr Src X
forall a s t. Eq a => Expr s a -> Expr t a
Core.normalize Expr Src X
expr)

normalizeHeaders :: Expr Src Void -> IO (Expr Src Void)
normalizeHeaders :: Expr Src X -> IO (Expr Src X)
normalizeHeaders Expr Src X
headersExpr = do
    let handler₀ :: SomeException -> IO (Expr Src X)
handler₀ (SomeException
e :: SomeException) = do
            {- Try to typecheck using the preferred @mapKey@/@mapValue@ fields
               and fall back to @header@/@value@ if that fails. However, if
               @header@/@value@ still fails then re-throw the original exception
               for @mapKey@ / @mapValue@. -}
            let handler₁ :: SomeException -> m a
handler₁ (SomeException
_ :: SomeException) = SomeException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM SomeException
e
            (SomeException -> IO (Expr Src X))
-> IO (Expr Src X) -> IO (Expr Src X)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle SomeException -> IO (Expr Src X)
forall {m :: * -> *} {a}. MonadThrow m => SomeException -> m a
handler₁ (Expr Src X -> Expr Src X -> IO (Expr Src X)
typecheck Expr Src X
leagacyHeadersTypeExpr Expr Src X
headersExpr)

    (SomeException -> IO (Expr Src X))
-> IO (Expr Src X) -> IO (Expr Src X)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle SomeException -> IO (Expr Src X)
handler₀ (Expr Src X -> Expr Src X -> IO (Expr Src X)
typecheck Expr Src X
headersTypeExpr Expr Src X
headersExpr)

normalizeOriginHeaders :: Expr Src Void -> IO (Expr Src Void)
normalizeOriginHeaders :: Expr Src X -> IO (Expr Src X)
normalizeOriginHeaders = Expr Src X -> Expr Src X -> IO (Expr Src X)
typecheck Expr Src X
originHeadersTypeExpr