Securely trigger personal scripts from incoming HTTP requests
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

Generic.hs 2.8KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970
  1. {-# LANGUAGE FlexibleInstances #-}
  2. {-# LANGUAGE MultiParamTypeClasses #-}
  3. {-# LANGUAGE TemplateHaskell #-}
  4. {-
  5. This file is part of the package personal-webhooks. It is subject to
  6. the license terms in the LICENSE file found in the top-level directory
  7. of this distribution and at:
  8. git://git.devalot.com/personal-webhooks.git
  9. No part of this package, including this file, may be copied, modified,
  10. propagated, or distributed except according to the terms contained in
  11. the LICENSE file.
  12. -}
  13. --------------------------------------------------------------------------------
  14. -- | Use generic PostgreSQL columns to hold Haskell types.
  15. module Web.Hooks.Personal.Internal.Database.Generic
  16. ( LiftJSON(..)
  17. , liftJSON
  18. ) where
  19. --------------------------------------------------------------------------------
  20. -- Library Imports:
  21. import Data.Aeson (ToJSON, FromJSON)
  22. import qualified Data.Aeson as Aeson
  23. import Data.Profunctor.Product.Default (Default(def))
  24. import Data.Typeable (Typeable)
  25. import Database.PostgreSQL.Simple.FromField (FromField(..), Conversion, ResultError(..), returnError)
  26. import qualified Language.Haskell.TH as TH
  27. import Opaleye hiding (FromField)
  28. --------------------------------------------------------------------------------
  29. -- | A type wrapper to lift another type into PostgreSQL via @PGJson@.
  30. newtype LiftJSON a = LiftJSON { unliftJSON :: a }
  31. --------------------------------------------------------------------------------
  32. instance (FromJSON a, Typeable a) => FromField (LiftJSON a) where
  33. fromField f b = go =<< fromField f b
  34. where
  35. go :: (FromJSON a, Typeable a) => Aeson.Value -> Conversion (LiftJSON a)
  36. go v = case Aeson.fromJSON v of
  37. Aeson.Success x -> return (LiftJSON x)
  38. Aeson.Error e -> returnError ConversionFailed f e
  39. --------------------------------------------------------------------------------
  40. instance (FromJSON a, Typeable a) => QueryRunnerColumnDefault PGJson (LiftJSON a) where
  41. queryRunnerColumnDefault = fieldQueryRunnerColumn
  42. --------------------------------------------------------------------------------
  43. instance (ToJSON a) => Default Constant (LiftJSON a) (Column PGJson) where
  44. def = Constant (pgValueJSON . Aeson.toJSON . unliftJSON)
  45. --------------------------------------------------------------------------------
  46. -- | Use Template Haskell to generate database instances for @PGJson@.
  47. liftJSON :: TH.Name -> TH.Q [TH.Dec]
  48. liftJSON name =
  49. [d|
  50. instance FromField $(TH.conT name) where
  51. fromField f b = unliftJSON <$> fromField f b
  52. instance QueryRunnerColumnDefault PGJson $(TH.conT name) where
  53. queryRunnerColumnDefault = unliftJSON <$> queryRunnerColumnDefault
  54. instance Default Constant $(TH.conT name) (Column PGJson) where
  55. def = Constant (pgValueJSON . Aeson.toJSON)
  56. |]