module Model.Types.TH.Binary where

import ClassyPrelude.Yesod hiding (Proxy(..))
import Database.Persist.Sql

import qualified Data.ByteString.Lazy as LBS

import Language.Haskell.TH
import Language.Haskell.TH.Datatype
import qualified Language.Haskell.TH.Syntax as TH

import Utils.Persist
import Data.Proxy

import Data.Binary (Binary)
import qualified Data.Binary as Binary

import Data.List (foldl)

import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson

import qualified Data.ByteString.Base64.URL as Base64

import Control.Monad.Fail


toPersistValueBinary :: Binary a => a -> PersistValue
toPersistValueBinary = PersistByteString . LBS.toStrict . Binary.encode

fromPersistValueBinary :: forall a. (Binary a, PersistFieldSql a, Typeable a) => PersistValue -> Either Text a
fromPersistValueBinary = \case
  PersistByteString bs
    | Right (rest, _, v) <- Binary.decodeOrFail $ fromStrict bs
    , null rest
      -> Right v
  x -> Left $ fromPersistValueErrorSql (Proxy @a) x

sqlTypeBinary :: SqlType
sqlTypeBinary = SqlBlob


derivePersistFieldBinary :: Name -> DecsQ
derivePersistFieldBinary tName = do
  DatatypeInfo{..} <- reifyDatatype tName
  vars <- forM datatypeVars (const $ newName "a")
  let t = foldl (\t' n' -> t' `appT` varT n') (conT tName) vars
      iCxt
        | null vars = cxt []
        | otherwise = cxt [[t|Binary|] `appT` t, [t|Typeable|] `appT` t]
      sqlCxt
        | null vars = cxt []
        | otherwise = cxt [[t|PersistField|] `appT` t]
  sequence
    [ instanceD iCxt ([t|PersistField|] `appT` t)
      [ funD 'toPersistValue
        [ clause [] (normalB [e|toPersistValueBinary|]) []
        ]
      , funD 'fromPersistValue
        [ clause [] (normalB [e|fromPersistValueBinary|]) []
        ]
      ]
    , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
      [ funD 'sqlType
        [ clause [wildP] (normalB [e|sqlTypeBinary|]) []
        ]
      ]
    ]


toJSONBinary :: Binary a => a -> Aeson.Value
toJSONBinary = Aeson.String . decodeUtf8 . Base64.encode . toStrict . Binary.encode

parseJSONBinary :: Binary a => Name -> Aeson.Value -> Aeson.Parser a
parseJSONBinary n = Aeson.withText (nameBase n) $ \t -> do
  bytes <- either fail (return . fromStrict) . Base64.decode $ encodeUtf8 t
  case Binary.decodeOrFail bytes of
    Left (_, _, err) -> fail err
    Right (bs, _, ret)
      | null bs -> return ret
      | otherwise -> fail $ show (length bs) ++ " extra bytes"

  
deriveJSONBinary :: Name -> DecsQ
deriveJSONBinary tName = do
  DatatypeInfo{..} <- reifyDatatype tName
  vars <- forM datatypeVars (const $ newName "a")
  let t = foldl (\t' n' -> t' `appT` varT n') (conT tName) vars
      iCxt
        | null vars = cxt []
        | otherwise = cxt [[t|Binary|] `appT` t, [t|Typeable|] `appT` t]
  sequence
    [ instanceD iCxt ([t|ToJSON|] `appT` t)
      [ funD 'toJSON
        [ clause [] (normalB [e|toJSONBinary|]) []
        ]
      ]
    , instanceD iCxt ([t|FromJSON|] `appT` t)
      [ funD 'parseJSON
        [ clause [] (normalB [e|parseJSONBinary $(TH.lift tName)|]) []
        ]
      ]
    ]
