{-# 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.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) = forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList (forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
Data.Foldable.fold Maybe (Seq HTTPHeader)
maybeHeaders)
  where
      maybeHeaders :: Maybe (Seq HTTPHeader)
maybeHeaders = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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
    (forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> TextLit (Chunks [] Text
keyText), forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> TextLit (Chunks [] Text
valueText))
        <- Maybe (RecordField s a, RecordField s a)
lookupHeader 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
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall s. FoldCase s => s -> CI s
Data.CaseInsensitive.mk ByteString
keyBytes, ByteString
valueBytes)
      where
        lookupHeader :: Maybe (RecordField s a, RecordField s a)
lookupHeader = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Text
"header" Map Text (RecordField s a)
m) (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 = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Text
"mapKey" Map Text (RecordField s a)
m) (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
_ =
    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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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) = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList (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
_ = forall a. Monoid a => a
mempty

    originPairs :: t (Expr s a) -> [(Text, [HTTPHeader])]
originPairs t (Expr s a)
hs = forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList (forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
Data.Foldable.fold (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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
      (forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> TextLit (Chunks [] Text
keyText), forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Expr s a
value)
          <- Maybe (RecordField s a, RecordField s a)
lookupMapKey
      forall (m :: * -> *) a. Monad m => a -> m a
return (Text
keyText, forall s a. Expr s a -> [HTTPHeader]
toHeaders Expr s a
value)
        where
          lookupMapKey :: Maybe (RecordField s a, RecordField s a)
lookupMapKey = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Text
"mapKey" Map Text (RecordField s a)
m) (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
_ = forall a. Maybe a
Nothing

makeHeadersTypeExpr :: Text -> Text -> Expr Src Void
makeHeadersTypeExpr :: Text -> Text -> Expr Src X
makeHeadersTypeExpr Text
keyKey Text
valueKey =
  forall s a. Expr s a -> Expr s a -> Expr s a
App forall s a. Expr s a
List
      ( forall s a. Map Text (RecordField s a) -> Expr s a
Record forall a b. (a -> b) -> a -> b
$ forall s a. Expr s a -> RecordField s a
Core.makeRecordField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          forall k v. Ord k => [(k, v)] -> Map k v
Dhall.Map.fromList
              [ (Text
keyKey, forall s a. Expr s a
Text)
              , (Text
valueKey, 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 =
  forall s a. Expr s a -> Expr s a -> Expr s a
App forall s a. Expr s a
List
      ( forall s a. Map Text (RecordField s a) -> Expr s a
Record forall a b. (a -> b) -> a -> b
$ forall s a. Expr s a -> RecordField s a
Core.makeRecordField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          forall k v. Ord k => [(k, v)] -> Map k v
Dhall.Map.fromList
              [ (Text
"mapKey", 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_ = 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
_ ->
                forall s a. s -> Expr s a -> Expr s a
Note (SourcePos -> SourcePos -> Text -> Src
Src SourcePos
begin SourcePos
end Text
bytes') (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 forall a. Semigroup a => a -> a -> a
<> Text
" : " forall a. Semigroup a => a -> a -> a
<> Text
suffix_
            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 (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 -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM TypeError Src X
err
        Right Expr Src X
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    forall (m :: * -> *) a. Monad m => a -> m a
return (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) = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e
            forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle 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)

    forall (m :: * -> *) e a.
(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