{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

module Snap.Snaplet.Stripe
       ( HasStripe (..)
       , StripeState (..)
       , initStripe
       , addStripeSplices
       , addCustomer
       , addCustomerWithCard
       , addCardByCustId
       , chargeCustomer
       , chargeConnectCustomer
       , fromAmount
       , toAmount
       , charge
       , connectCharge
       , customer
       , getAuthURL
       ) where


import           Control.Applicative        ((<$>), (<*>))
import           Control.Monad              (when)
import           Control.Monad.State        (get)
import           Control.Monad.Trans        (MonadIO, lift, liftIO)
import           Control.Monad.Trans.Writer (WriterT, runWriterT, tell)
import qualified Data.Configurator          as C
import           Data.List                  (intercalate)
import           Data.Maybe                 (fromMaybe, isNothing)
import           Data.Monoid                (mempty)
import           Data.Text                  (Text)
import           Data.Text.Format           (Format, Only (..), format)
import qualified Data.Text.Lazy             as TL
import           Heist                      (HeistConfig (..))
import           Heist.Compiled             (nodeSplice, pureSplice)
import           Heist.SpliceAPI            (( ## ))
import           Snap.Snaplet               (Handler, Initializer, Snaplet,
                                             SnapletInit, SnapletLens,
                                             getSnapletUserConfig, makeSnaplet,
                                             with)
import           Snap.Snaplet.Heist         (HasHeist, Heist, SnapletCSplice,
                                             SnapletISplice, addConfig)
import           Text.XmlHtml               (Node (..))

import           Web.Stripe.Charge          (Amount (..), Charge, ChargeId,
                                             Currency, chargeCustomerById,
                                             chargeTokenById, getCharge)
import           Web.Stripe.Client          (SecretKey (..), StripeConfig (..),
                                             StripeFailure, StripeVersion (..),
                                             runStripeT, stripeSecretKey)
import           Web.Stripe.Connect         (AccessToken, ClientId, Landing,
                                             Scope, URL, authURL,
                                             createCustomerToken)
import           Web.Stripe.Coupon          (CpnId)
import           Web.Stripe.Customer        (Customer, CustomerId, Description,
                                             Email, createCustomerByTokenId,
                                             getCustomer,
                                             updateCustomerByIdByTokenId)
import           Web.Stripe.Plan            (PlanId)
import           Web.Stripe.Token           (TokenId, tokId)


newtype PublicKey = PublicKey { unPublicKey :: Text } deriving (Show, Eq)

data StripeState = StripeState
    { stripeConfig          :: StripeConfig
    , stripePublicKey       :: PublicKey
    , stripeConnectClientId :: ClientId
    } deriving Show


class HasStripe b where
    getStripeState :: b StripeState


instance HasStripe (Handler b StripeState) where
    getStripeState = get


logErr :: MonadIO m => t -> IO (Maybe a) -> WriterT [t] m (Maybe a)
logErr err m = do
  res <- liftIO m
  when (isNothing res) (tell [err])
  return res


initStripe :: SnapletInit b StripeState
initStripe = makeSnaplet "stripe" "Stripe credit card payment" Nothing $ do
  config <- getSnapletUserConfig

  (stripeState, errors) <- runWriterT $ do
    secretKey <- logErr "Must specify Strip secret key"  $ C.lookup config "secret_key"
    publicKey <- logErr "Must specify Strip public key"  $ C.lookup config "public_key"
    clientId  <- logErr "Must specify Strip client ID"   $ C.lookup config "client_id"
    version   <- Just . maybe V20110915d OtherVersion <$> liftIO (C.lookup config "version")
    let caFilePath = Just "" -- This is unused by Stripe but vestigial in the Haskell library.

    return $ StripeState <$> (StripeConfig <$> (SecretKey <$> secretKey) <*> caFilePath <*> version) <*> (PublicKey <$> publicKey) <*> clientId
  return $ fromMaybe (error $ intercalate "\n" errors) stripeState


withSC :: (Functor m, HasStripe m, MonadIO m) => (StripeConfig -> m b) -> m b
withSC = (stripeConfig <$> getStripeState >>=)


withSS :: (HasStripe m, MonadIO m) => (StripeState -> m b) -> m b
withSS = (getStripeState >>=)


addCustomer' :: (Functor m, HasStripe m, MonadIO m) => Maybe TokenId -> Maybe CpnId
             -> Maybe Email -> Maybe Description -> Maybe PlanId -> Maybe Int
             -> m (Either StripeFailure Customer)
addCustomer' mti mcid me md mpid mtime =
    withSC . flip runStripeT $ createCustomerByTokenId mti mcid me md mpid mtime


customer :: (Functor m, HasStripe m, MonadIO m) => CustomerId -> m (Either StripeFailure Customer)
customer = withSC . flip runStripeT . getCustomer


getAuthURL :: (MonadIO m, HasStripe m) => Maybe Scope -> Maybe Text -> Maybe Landing -> m URL
getAuthURL msc mst mld = withSS $ return . authURL msc mst mld . stripeConnectClientId


chargeCustomer :: (Functor m, HasStripe m, MonadIO m) => CustomerId -> Amount -> Currency
               -> Maybe Description -> m (Either StripeFailure Charge)
chargeCustomer cid a c md =
  withSC . flip runStripeT $ chargeCustomerById cid a c md Nothing


chargeConnectCustomer :: (Functor m, HasStripe m, MonadIO m) => CustomerId -> Amount -> Currency
                      -> Maybe Description -> AccessToken -> Maybe Amount
                      -> m (Either StripeFailure Charge)
chargeConnectCustomer cid am cu md k maf = withSC $ \sc -> do
  let sc' = sc { stripeSecretKey = accessTokenToKey k }
  let ch = tokId <$> createCustomerToken cid >>=
          (\tid -> chargeTokenById tid am cu md maf)
  runStripeT sc' ch


updateCustomerById :: (Functor m, HasStripe m, MonadIO m) => CustomerId -> Maybe TokenId
                   -> Maybe CpnId -> Maybe Email -> Maybe Description
                   -> m (Either StripeFailure Customer)
updateCustomerById cid mti mcid me md =
  withSC . flip runStripeT $ updateCustomerByIdByTokenId cid mti mcid me md


connectCharge :: (Functor m, HasStripe m, MonadIO m) => AccessToken -> ChargeId
                 -> m (Either StripeFailure Charge)
connectCharge k c = withSC $ \sc -> do
  let sc' = sc { stripeSecretKey = accessTokenToKey k }
  runStripeT sc' (getCharge c)


charge :: (Functor m, HasStripe m, MonadIO m) => ChargeId -> m (Either StripeFailure Charge)
charge = withSC . flip runStripeT . getCharge


-- Simple API helpers --
addCustomer :: (Functor m, HasStripe m, MonadIO m) => Email -> m (Either StripeFailure Customer)
addCustomer email = addCustomer' Nothing Nothing (Just email) Nothing Nothing Nothing


addCustomerWithCard :: (Functor m, HasStripe m, MonadIO m) => Email -> TokenId
                    -> m (Either StripeFailure Customer)
addCustomerWithCard email tid =
    addCustomer' (Just tid) Nothing (Just email) Nothing Nothing Nothing


addCardByCustId :: (Functor m, HasStripe m, MonadIO m) => CustomerId -> TokenId
                -> m (Either StripeFailure Customer)
addCardByCustId cid tid = updateCustomerById cid (Just tid) Nothing Nothing Nothing


-- Functional Helpers
toAmount :: Float -> Amount
toAmount = Amount . truncate . (* 100)


fromAmount :: Amount -> Float
fromAmount = (/ 100) . fromIntegral . unAmount


accessTokenToKey :: AccessToken -> SecretKey
accessTokenToKey = SecretKey


-- Public Key Splice
addStripeSplices :: HasHeist b => Snaplet (Heist b) -> SnapletLens b StripeState -> Initializer b v ()
addStripeSplices h stripe = addConfig h $ mempty
    { hcCompiledSplices    = ("stripePublicKeyJs" ## stripePublicKeyJsCSplice stripe)
    , hcInterpretedSplices = ("stripePublicKeyJs" ## stripePublicKeyJsISplice stripe)
    }


stripePublicKeyJsISplice :: SnapletLens b StripeState -> SnapletISplice b
stripePublicKeyJsISplice stripe = return . ssNodes =<< (lift $ with stripe getStripeState)


stripePublicKeyJsCSplice :: SnapletLens b StripeState -> SnapletCSplice b
stripePublicKeyJsCSplice stripe = (pureSplice . nodeSplice) ssNodes . lift $ with stripe getStripeState


ssNodes :: StripeState -> [Node]
ssNodes = scriptNodes . renderJs . unPublicKey . stripePublicKey
  where renderJs = TL.toStrict . format ("var stripePublicKey = '{}';" :: Format) . Only . TL.fromStrict
        scriptNodes t = [Element "script" [("type", "text/javascript")] [TextNode t]]