{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE OverlappingInstances       #-}
{-# LANGUAGE OverloadedLists            #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}
module Utils where

import           Control.Monad                        (unless, when)
import           Control.Monad.Base                   (MonadBase (..))
import           Control.Monad.Error.Class
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Control          (MonadBaseControl (..))
import           Control.Monad.Trans.Except
import           Control.Monad.Trans.Reader
import           Data.Aeson                           hiding (Null)
import qualified Data.Aeson.Types                     as JSON
import           Data.Char                            (toLower)
import qualified Data.Char                            as Char
import qualified Data.Map.Lazy                        as Map
import qualified Data.Pool                            as Pool
import           Data.String
import           Data.Text                            (Text)
import qualified Data.Text                            as Text
import qualified Data.Text.Encoding                   as TE
import qualified Data.Time                            as Time
import           Data.Typeable
import           Data.UUID                            (UUID, fromASCIIBytes,
                                                       toASCIIBytes)
import qualified Data.UUID                            as UUID
import qualified Database.PostgreSQL.Simple           as PGS
import           Database.PostgreSQL.Simple.FromField (Conversion,
                                                       FromField (..),
                                                       ResultError (..),
                                                       returnError)
import           Generics.SOP
import qualified GHC.Generics                         as GHC
import           Protolude                            hiding (All, Generic,
                                                       from, to)
import           Servant

--------------------------------------------------------------------------------
data Undefined = Undefined

instance FromJSON Undefined where
  parseJSON _ = return Undefined

instance ToJSON Undefined where
  toJSON Undefined = JSON.Null

--------------------------------------------------------------------------------
data Env = Env
  { envPool :: PGPool
  }

--------------------------------------------------------------------------------
type ResponseT = ReaderT Env Handler

--------------------------------------------------------------------------------
customOptions :: JSON.Options
customOptions = JSON.defaultOptions { JSON.omitNothingFields = True
                                    , JSON.constructorTagModifier = JSON.camelTo2 '_' . fmap toLower
                                    }

--------------------------------------------------------------------------------
prefixOptions :: JSON.Options
prefixOptions = JSON.defaultOptions { JSON.fieldLabelModifier = modifier
                                    , JSON.omitNothingFields = True
                                    , JSON.constructorTagModifier = JSON.camelTo2 '_' . fmap toLower
                                    }

--------------------------------------------------------------------------------
class (a ~ b) => Equal a b
instance (a ~ b) => Equal a b

--------------------------------------------------------------------------------
gToText :: (Generic a, All (Equal '[]) (Code a)) => NP (K Text) (Code a) -> a -> Text
gToText names = hcollapse . hzipWith const names . unSOP . from

--------------------------------------------------------------------------------
gFromText :: (Generic a, All (Equal '[]) (Code a)) => NP (K Text) (Code a) -> Text -> Either Text a
gFromText names n = case Map.lookup n table of
    Just a  -> Right a
    Nothing -> Left $ "Failed to parse " <> n
  where
    table =
      Map.fromList
        (hcollapse
          (hczipWith (Proxy :: Proxy (Equal '[]))
            (\ (K n) (Fn c) -> K (n, to (SOP (unK (c Nil)))))
            names injections
          )
        )

--------------------------------------------------------------------------------
instance ToJSON UUID where toJSON = String . TE.decodeUtf8 . toASCIIBytes

instance FromJSON UUID where
  parseJSON json@(String t) =
    case fromASCIIBytes (TE.encodeUtf8 t) of
      Just uuid -> pure uuid
      Nothing   -> JSON.typeMismatch "UUID" json
  parseJSON unknown = JSON.typeMismatch "UUID" unknown

--------------------------------------------------------------------------------
transformFst :: (Char -> Char) -> String -> String
transformFst _ []     = []
transformFst f (x:xs) = f x : xs

--------------------------------------------------------------------------------
capitalize :: String -> String
capitalize = transformFst Char.toUpper

--------------------------------------------------------------------------------
uncapitalize :: String -> String
uncapitalize = transformFst Char.toLower

--------------------------------------------------------------------------------
split :: (Char -> Bool) -> String -> [String]
split p s = case dropWhile p s of
    "" -> []
    s' -> w : split p s''
          where
            (w, s'') = break p s'

--------------------------------------------------------------------------------
toCamelCase :: String -> String
toCamelCase = concat . map' . split (== '_')
  where
    map' = map capitalize

--------------------------------------------------------------------------------
toMixedCase :: String -> String
toMixedCase = uncapitalize . toCamelCase

--------------------------------------------------------------------------------
modifier :: String -> String
modifier = toMixedCase . drop 1 . dropWhile (/= '_') . JSON.camelTo2 '_'

--------------------------------------------------------------------------------
-- | Simple alias for PostgreSQL connection pools.
type PGPool = Pool.Pool PGS.Connection

--------------------------------------------------------------------------------
-- | Create a @'PostgresPool'@ connection pool.
createPostgresPool :: Maybe PGS.ConnectInfo
                   -- ^ Optional connection information.
                   -> Int
                   -- ^ Number of stripes.
                   -> Time.NominalDiffTime
                   -- ^ Time to keep unused connections open.
                   -> Int
                   -- ^ Maximum connections per stripe.
                   -> IO PGPool
createPostgresPool connInfo = go where
  go   = Pool.createPool (PGS.connectPostgreSQL info) PGS.close
  info = PGS.postgreSQLConnectionString
       $ fromMaybe PGS.defaultConnectInfo connInfo

--------------------------------------------------------------------------------
class Versioned a where
  getVersion :: a -> Int64

--------------------------------------------------------------------------------
requireVersion :: Versioned a => a -> Maybe Int64 -> ResponseT a
requireVersion entity mbGivenVer =
  case mbGivenVer of
    Nothing -> throwError $ ServantErr 428 "Precondition Required" "You must supply your current enity version in the `If-Match` header" []
    Just version ->
      if getVersion entity == version
        then pure entity
        else throwError err412 { errBody = "The version you supplied is stale. The entity has changed since your last read. Please update and retry your operation." }

--------------------------------------------------------------------------------
checkNewVersion :: Versioned a => a -> Maybe Int64 -> ResponseT a
checkNewVersion entity mbGivenVer =
  case mbGivenVer of
    Nothing -> return entity
    Just version ->
      if getVersion entity > version
        then pure entity
        else throwError err304
