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

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

import Control.Applicative     (Alternative (..), liftA2)
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.TypeCheck
import qualified Dhall.Pretty.Internal

-- | 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 :: Expr s a -> [HTTPHeader]
toHeaders (ListLit Maybe (Expr s a)
_ Seq (Expr s a)
hs) = Seq HTTPHeader -> [HTTPHeader]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList (Maybe (Seq HTTPHeader) -> Seq HTTPHeader
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)
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 :: 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 (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 (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 (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 (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 (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 Void -> IO OriginHeaders
toOriginHeaders Expr Src Void
expr = (Expr Src Void -> OriginHeaders)
-> IO (Expr Src Void) -> IO OriginHeaders
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr Src Void -> OriginHeaders
forall s a. Expr s a -> OriginHeaders
convert (Expr Src Void -> IO (Expr Src Void)
normalizeOriginHeaders Expr Src Void
expr)
  where
    convert :: Expr s a -> OriginHeaders
    convert :: 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 (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList (Maybe (t (Text, [HTTPHeader])) -> t (Text, [HTTPHeader])
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)
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 :: 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 (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 (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 Void
makeHeadersTypeExpr Text
keyKey Text
valueKey =
  Expr Src Void -> Expr Src Void -> Expr Src Void
forall s a. Expr s a -> Expr s a -> Expr s a
App Expr Src Void
forall s a. Expr s a
List
      ( Map Text (RecordField Src Void) -> Expr Src Void
forall s a. Map Text (RecordField s a) -> Expr s a
Record (Map Text (RecordField Src Void) -> Expr Src Void)
-> Map Text (RecordField Src Void) -> Expr Src Void
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> RecordField Src Void
forall s a. Expr s a -> RecordField s a
Core.makeRecordField (Expr Src Void -> RecordField Src Void)
-> Map Text (Expr Src Void) -> Map Text (RecordField Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          [(Text, Expr Src Void)] -> Map Text (Expr Src Void)
forall k v. Ord k => [(k, v)] -> Map k v
Dhall.Map.fromList
              [ (Text
keyKey, Expr Src Void
forall s a. Expr s a
Text)
              , (Text
valueKey, Expr Src Void
forall s a. Expr s a
Text)
              ]
      )

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

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

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

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

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

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

normalizeHeaders :: Expr Src Void -> IO (Expr Src Void)
normalizeHeaders :: Expr Src Void -> IO (Expr Src Void)
normalizeHeaders Expr Src Void
headersExpr = do
    let handler₀ :: SomeException -> IO (Expr Src Void)
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 (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e
            (SomeException -> IO (Expr Src Void))
-> IO (Expr Src Void) -> IO (Expr Src Void)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle SomeException -> IO (Expr Src Void)
forall (m :: * -> *) a. MonadThrow m => SomeException -> m a
handler₁ (Expr Src Void -> Expr Src Void -> IO (Expr Src Void)
typecheck Expr Src Void
leagacyHeadersTypeExpr Expr Src Void
headersExpr)

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

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