src/Worksheets/Utils/SQL.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE UndecidableInstances #-}
   3 {-# OPTIONS_GHC -Wno-orphans #-}
   4
   5 module Worksheets.Utils.SQL (
   6   module Worksheets.Utils.SQL,
   7   module Database.SQLite.Simple,
   8   module Database.SQLite.Simple.FromRow,
   9   module Database.SQLite.Simple.FromField,
  10   module Database.SQLite.Simple.ToField,
  11   module Database.SQLite.Simple.Ok,
  12   module Database.SQLite.Simple.Internal,
  13 ) where
  14
  15 import Control.Exception (Exception, SomeException (..))
  16 import Control.Monad.Trans.Class qualified as MT
  17 import Control.Monad.Trans.Reader qualified as MT
  18 import Control.Monad.Trans.State.Strict qualified as MT
  19 import Data.Aeson qualified as JSON
  20 import Data.List qualified as List
  21 import Data.Text.Encoding qualified as Text
  22 import Data.Text.Lazy qualified as LazyText
  23 import Data.Text.Short qualified as ShortText
  24 import Database.SQLite.Simple
  25 import Database.SQLite.Simple.FromField
  26 import Database.SQLite.Simple.FromRow
  27 import Database.SQLite.Simple.Internal
  28 import Database.SQLite.Simple.Ok (ManyErrors (..), Ok (..))
  29 import Database.SQLite.Simple.ToField
  30 import Database.SQLite.Simple.ToRow
  31 import Database.SQLite3 qualified as SQL.Base
  32 import Text.Show (showString)
  33
  34 import Worksheets.Utils.Generics qualified as Gen
  35 import Worksheets.Utils.Prelude
  36
  37 -- DOC: https://highperformancesqlite.com/articles/sqlite-recommended-pragmas
  38 --
  39 -- PRAGMA foreign_keys = ON;
  40 -- PRAGMA journal_mode = WAL;
  41 -- PRAGMA mmap_size = 268435456; --256MB
  42 -- PRAGMA page_size = 8192;
  43
  44 class GFromRowWithErrorContext f where gfromRowWithErrorContext :: RowParser (f a)
  45 instance GFromRowWithErrorContext Gen.U1 where
  46   gfromRowWithErrorContext = pure Gen.U1
  47 instance FromField a => GFromRowWithErrorContext (Gen.K1 i a) where
  48   gfromRowWithErrorContext = Gen.K1 <$> fromFieldWithErrorContext
  49 instance GFromRowWithErrorContext a => GFromRowWithErrorContext (Gen.M1 i c a) where
  50   gfromRowWithErrorContext = Gen.M1 <$> gfromRowWithErrorContext
  51 instance (GFromRowWithErrorContext a, GFromRowWithErrorContext b) => GFromRowWithErrorContext (a Gen.:*: b) where
  52   gfromRowWithErrorContext = (Gen.:*:) <$> gfromRowWithErrorContext <*> gfromRowWithErrorContext
  53
  54 fromFieldWithErrorContext :: FromField a => RowParser a
  55 fromFieldWithErrorContext = fieldWithErrorContext fromField
  56 {-# INLINE fromFieldWithErrorContext #-}
  57
  58 -- | Enables the use of:
  59 -- @
  60 -- deriving (`ToRow`, `FromRow`) via (`GenericallyWithOptions` MyDataType)
  61 -- @
  62 newtype GenericallyWithOptions a = GenericallyWithOptions a
  63
  64 instance (Generic a, GFromRowWithErrorContext (Gen.Rep a)) => FromRow (GenericallyWithOptions a) where
  65   fromRow = gfromRowWithErrorContext <&> (Gen.to >>> GenericallyWithOptions)
  66 instance (Generic a, GToRow (Gen.Rep a)) => ToRow (GenericallyWithOptions a) where
  67   toRow (GenericallyWithOptions x) = Gen.from x & gtoRow
  68
  69 instance ToField ShortText where
  70   toField = SQLText . ShortText.toText
  71 instance FromField ShortText where
  72   -- fromField = fromField >>> fmap ShortText.fromText
  73   fromField (Field (SQLText txt) _) = Ok $ txt & ShortText.fromText
  74   fromField f@(Field d col) = returnError ConversionFailed f $ "need an SQLText at column=" <> show col <> " but got: " <> show d
  75
  76 data FieldErrorContext = FieldErrorContext
  77   { fieldErrorContextRemainingColumns :: [SQL.Base.SQLData]
  78   }
  79 instance Show FieldErrorContext where
  80   showsPrec _p FieldErrorContext{..} = showString (pShow fieldErrorContextRemainingColumns & LazyText.unpack)
  81 instance Exception FieldErrorContext
  82
  83 fieldWithErrorContext :: FieldParser a -> RowParser a
  84 fieldWithErrorContext fieldP = RP $ do
  85   ncols <- MT.asks nColumns
  86   (column, remaining) <- MT.lift MT.get
  87   MT.lift (MT.put (column + 1, List.tail remaining))
  88   if column >= ncols
  89     then MT.lift (MT.lift (Errors [SomeException (ColumnOutOfBounds (column + 1))]))
  90     else do
  91       let r = List.head remaining
  92       let fld = Field r column
  93       MT.lift do
  94         MT.lift do
  95           let f = fieldP fld
  96           case f of
  97             Errors errs -> do
  98               let err = FieldErrorContext remaining
  99               Errors (SomeException err : errs)
 100             _ -> f
 101
 102 instance FromField JSON.Value where
 103   fromField = fromJSONField JSON.Null
 104 instance ToField JSON.Value where
 105   toField = JSON.encode >>> toField
 106
 107 instance FromField JSON.Array where
 108   fromField = fromJSONField mempty
 109 instance ToField JSON.Array where
 110   toField = toJSONField
 111
 112 instance JSON.ToJSON a => ToField [a] where
 113   toField = toJSONField
 114 instance (JSON.FromJSON a, Typeable a) => FromField [a] where
 115   fromField = fromJSONField []
 116
 117 -- | Uses `JSON.eitherDecodeStrict` and expect the JSON
 118 -- to be stored in an `BLOB` column.
 119 --
 120 -- Beware that SQlite does not enforces `BLOB` columns
 121 -- to contain only `BLOB` data, they could be `TEXT`,
 122 -- so you have to check that the way you `INSERT`
 123 -- is indeed inserting a `BLOB`,
 124 -- eg. in Python `bytes()` must be used:
 125 -- @
 126 -- bytes(json.dumps(value, ensure_ascii=False),'utf-8')
 127 -- @
 128 fromJSONField :: JSON.FromJSON a => Typeable a => a -> Field -> Ok a
 129 fromJSONField empt fld =
 130   fromField fld & \case
 131     Errors{} ->
 132       fromField fld & \case
 133         Errors err -> Ok empt
 134         -- returnError Incompatible fld $ show err
 135         Ok txt -> txt & Text.encodeUtf8 & decodeBS
 136     Ok bs -> bs & decodeBS
 137   where
 138     decodeBS bs =
 139       case JSON.eitherDecodeStrict bs of
 140         Left err -> returnError ConversionFailed fld err
 141         Right val ->
 142           case JSON.fromJSON val of
 143             JSON.Error err -> returnError ConversionFailed fld err
 144             JSON.Success a -> Ok a
 145
 146 toJSONField :: JSON.ToJSON a => a -> SQLData
 147 toJSONField = JSON.toJSON >>> toField
 148
 149 selectors :: forall a. Gen.DataSelectorNames (Gen.Rep a ()) => Query
 150 selectors =
 151   Gen.dataSelectorNames @(Gen.Rep a ())
 152     <&> Gen.dropUntilUnderscore
 153     & List.intercalate ","
 154     & fromString