{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}

module Network.AWS.CloudFront.SignedCookies.Policy
  (
  -- * Defining a policy
    Policy (..)
  , simplePolicy

  -- * Components of a policy
  , Resource (..)
  , StartTime (..)
  , EndTime (..)
  , Lifespan (..)
  , IpAddress (..)

  -- * JSON representation
  , policyJSON
  , jsonTextPolicy
  , jsonValPolicy

  ) where

import Network.AWS.CloudFront.SignedCookies.Types

-- aeson
import qualified Data.Aeson as A

-- base
import Control.Monad ((>=>))
import Data.Semigroup ((<>))

-- bytestring
import qualified Data.ByteString.Lazy as LBS

-- lens
import Control.Lens ((&), (^.), (^?))

-- lens-aeson
import Data.Aeson.Lens (AsNumber (..), AsPrimitive (..), key, nth, _Array, _Object)

-- text
import qualified Data.Text.Encoding as Text

-- time
import Data.Time.Clock.POSIX (getPOSIXTime)

-- unordered-containers
import qualified Data.HashMap.Strict as Map

-- vector
import qualified Data.Vector as Vec

{- |

Encode a 'Policy' as JSON, with no whitespace, as AWS requires.

Excerpt from [Setting Signed Cookies Using a Custom Policy](https://docs.aws.amazon.com/AmazonCloudFront/latest/DeveloperGuide/private-content-setting-signed-cookie-custom-policy.html):

* "Remove all whitespace (including tabs and newline characters) from the policy statement."

-}

policyJSON :: Policy -> ByteString
policyJSON :: Policy -> ByteString
policyJSON =
  ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (Policy -> ByteString) -> Policy -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Value -> ByteString) -> (Policy -> Value) -> Policy -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Policy -> Value
policyValue

policyValue :: Policy -> A.Value
policyValue :: Policy -> Value
policyValue Policy
policy =
  Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton Text
"Statement" (Value -> Object) -> Value -> Object
forall a b. (a -> b) -> a -> b
$
    Array -> Value
A.Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Array
forall a. a -> Vector a
Vec.singleton (Value -> Array) -> Value -> Array
forall a b. (a -> b) -> a -> b
$
      Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text
"Resource" Text -> Value -> Object
.= Policy -> Value
resourceValue Policy
policy Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<>
                 Text
"Condition" Text -> Value -> Object
.= Policy -> Value
conditionValue Policy
policy

resourceValue :: Policy -> A.Value
resourceValue :: Policy -> Value
resourceValue (Policy (Resource Text
x) StartTime
_ EndTime
_ IpAddress
_) = Text -> Value
A.String Text
x

conditionValue :: Policy -> A.Value
conditionValue :: Policy -> Value
conditionValue (Policy Resource
_ StartTime
start EndTime
end IpAddress
ip) =
  Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Object
startCondition Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> Object
endCondition Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> Object
ipCondition
  where

    Object
startCondition :: A.Object =
      case StartTime
start of
        StartTime
StartImmediately -> Object
forall a. Monoid a => a
mempty
        StartTime POSIXTime
x -> Text
"DateGreaterThan" Text -> Value -> Object
.= POSIXTime -> Value
posixTimeValue POSIXTime
x

    Object
endCondition :: A.Object =
      case EndTime
end of
        EndTime POSIXTime
x -> Text
"DateLessThan" Text -> Value -> Object
.= POSIXTime -> Value
posixTimeValue POSIXTime
x

    Object
ipCondition :: A.Object =
      case IpAddress
ip of
        IpAddress
AnyIp -> Object
forall a. Monoid a => a
mempty
        IpAddress Text
x -> Text
"IpAddress" Text -> Value -> Object
.= Text -> Value
sourceIpValue Text
x

posixTimeValue :: POSIXTime -> A.Value
posixTimeValue :: POSIXTime -> Value
posixTimeValue =
  Object -> Value
A.Object (Object -> Value) -> (POSIXTime -> Object) -> POSIXTime -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"AWS:EpochTime" Text -> Value -> Object
.=) (Value -> Object) -> (POSIXTime -> Value) -> POSIXTime -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Value
A.Number (Scientific -> Value)
-> (POSIXTime -> Scientific) -> POSIXTime -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Integer -> Scientific)
-> (POSIXTime -> Integer) -> POSIXTime -> Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round

sourceIpValue :: Text -> A.Value
sourceIpValue :: Text -> Value
sourceIpValue =
  Object -> Value
A.Object (Object -> Value) -> (Text -> Object) -> Text -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"AWS:SourceIp" Text -> Value -> Object
.=) (Value -> Object) -> (Text -> Value) -> Text -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
A.String

(.=) :: Text -> A.Value -> A.Object
.= :: Text -> Value -> Object
(.=) = Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton

jsonTextPolicy :: Text -> Either String Policy
jsonTextPolicy :: Text -> Either String Policy
jsonTextPolicy =
  (ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode' (ByteString -> Either String Value)
-> (Text -> ByteString) -> Text -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8) (Text -> Either String Value)
-> (Value -> Either String Policy) -> Text -> Either String Policy
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
  Value -> Either String Policy
jsonValPolicy

jsonValPolicy :: A.Value -> Either String Policy
jsonValPolicy :: Value -> Either String Policy
jsonValPolicy Value
val =
  Resource -> StartTime -> EndTime -> IpAddress -> Policy
Policy
    (Resource -> StartTime -> EndTime -> IpAddress -> Policy)
-> Either String Resource
-> Either String (StartTime -> EndTime -> IpAddress -> Policy)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either String Resource
jsonResource  Value
val
    Either String (StartTime -> EndTime -> IpAddress -> Policy)
-> Either String StartTime
-> Either String (EndTime -> IpAddress -> Policy)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either String StartTime
jsonStart     Value
val
    Either String (EndTime -> IpAddress -> Policy)
-> Either String EndTime -> Either String (IpAddress -> Policy)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either String EndTime
jsonEnd       Value
val
    Either String (IpAddress -> Policy)
-> Either String IpAddress -> Either String Policy
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either String IpAddress
jsonIpAddress Value
val

jsonResource :: A.Value -> Either String Resource
jsonResource :: Value -> Either String Resource
jsonResource Value
val =
  Either String Resource
-> (Resource -> Either String Resource)
-> Maybe Resource
-> Either String Resource
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String Resource
forall a b. a -> Either a b
Left String
"Missing \"Resource\"") Resource -> Either String Resource
forall a b. b -> Either a b
Right (Maybe Resource -> Either String Resource)
-> Maybe Resource -> Either String Resource
forall a b. (a -> b) -> a -> b
$
    (Text -> Resource) -> Maybe Text -> Maybe Resource
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Resource
Resource
      (Value
val Value -> Getting (First Text) Value Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"Statement"
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Traversal' Value Value
forall t. AsValue t => Int -> Traversal' t Value
nth Int
0
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"Resource"
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Text) Value Text
forall t. AsPrimitive t => Prism' t Text
_String)

jsonStart :: A.Value -> Either String StartTime
jsonStart :: Value -> Either String StartTime
jsonStart Value
val =
  StartTime -> Either String StartTime
forall a b. b -> Either a b
Right (StartTime -> Either String StartTime)
-> StartTime -> Either String StartTime
forall a b. (a -> b) -> a -> b
$
    StartTime -> (Integer -> StartTime) -> Maybe Integer -> StartTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StartTime
StartImmediately (POSIXTime -> StartTime
StartTime (POSIXTime -> StartTime)
-> (Integer -> POSIXTime) -> Integer -> StartTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> POSIXTime
forall a. Num a => Integer -> a
fromInteger)
      (Value
val Value -> Getting (First Integer) Value Integer -> Maybe Integer
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"Statement"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Traversal' Value Value
forall t. AsValue t => Int -> Traversal' t Value
nth Int
0
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"Condition"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"DateGreaterThan"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"AWS:EpochTime"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Integer) Value Integer
forall t. AsNumber t => Prism' t Integer
_Integer)

jsonEnd :: A.Value -> Either String EndTime
jsonEnd :: Value -> Either String EndTime
jsonEnd Value
val =
  Either String EndTime
-> (EndTime -> Either String EndTime)
-> Maybe EndTime
-> Either String EndTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String EndTime
forall a b. a -> Either a b
Left String
"Missing \"DateLessThan\"") EndTime -> Either String EndTime
forall a b. b -> Either a b
Right (Maybe EndTime -> Either String EndTime)
-> Maybe EndTime -> Either String EndTime
forall a b. (a -> b) -> a -> b
$
    (Integer -> EndTime) -> Maybe Integer -> Maybe EndTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (POSIXTime -> EndTime
EndTime (POSIXTime -> EndTime)
-> (Integer -> POSIXTime) -> Integer -> EndTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> POSIXTime
forall a. Num a => Integer -> a
fromInteger)
      (Value
val Value -> Getting (First Integer) Value Integer -> Maybe Integer
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"Statement"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Traversal' Value Value
forall t. AsValue t => Int -> Traversal' t Value
nth Int
0
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"Condition"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"DateLessThan"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"AWS:EpochTime"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Integer) Value Integer
forall t. AsNumber t => Prism' t Integer
_Integer)

jsonIpAddress :: A.Value -> Either String IpAddress
jsonIpAddress :: Value -> Either String IpAddress
jsonIpAddress Value
val =
  IpAddress -> Either String IpAddress
forall a b. b -> Either a b
Right (IpAddress -> Either String IpAddress)
-> IpAddress -> Either String IpAddress
forall a b. (a -> b) -> a -> b
$
    IpAddress -> (Text -> IpAddress) -> Maybe Text -> IpAddress
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IpAddress
AnyIp Text -> IpAddress
IpAddress
      (Value
val Value -> Getting (First Text) Value Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"Statement"
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Traversal' Value Value
forall t. AsValue t => Int -> Traversal' t Value
nth Int
0
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"Condition"
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"IpAddress"
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"AWS:SourceIp"
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Text) Value Text
forall t. AsPrimitive t => Prism' t Text
_String)

{- |

This function provides one convenient way to construct a simple 'Policy'.

For the full set of policy options, use the 'Policy' constructor directly.

-}

simplePolicy
  :: Resource   -- ^ URL that the policy will grant access to,
                --   optionally containing asterisks for wildcards
  -> Lifespan   -- ^ How long from now the credentials expire
  -> IO Policy

simplePolicy :: Resource -> Lifespan -> IO Policy
simplePolicy Resource
res Lifespan
life = do

  POSIXTime
now :: POSIXTime <- IO POSIXTime
getPOSIXTime

  let end :: EndTime
end = case Lifespan
life of Lifespan POSIXTime
x -> POSIXTime -> EndTime
EndTime (POSIXTime
now POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
+ POSIXTime
x)

  Policy -> IO Policy
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Policy :: Resource -> StartTime -> EndTime -> IpAddress -> Policy
Policy
      { policyResource :: Resource
policyResource  = Resource
res
      , policyEnd :: EndTime
policyEnd       = EndTime
end
      , policyStart :: StartTime
policyStart     = StartTime
StartImmediately
      , policyIpAddress :: IpAddress
policyIpAddress = IpAddress
AnyIp
      }