packages feed

ribbit (empty) → 0.1.0.0

raw patch · 6 files changed

+460/−0 lines, 6 filesdep +Onlydep +basedep +om-showsetup-changed

Dependencies added: Only, base, om-show, postgresql-simple, text

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright 2019 Owens Murray, LLC.++Permission is hereby granted, free of charge, to any person obtaining a+copy of this software and associated documentation files (the "Software"),+to deal in the Software without restriction, including without limitation+the rights to use, copy, modify, merge, publish, distribute, sublicense,+and/or sell copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL+THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,102 @@+# Ribbit++Ribbit is yet another type safe relational database+library for Haskell, heavily inspired by the amazing+[Servant](http://hackage.haskell.org/package/servant) library. The goal+is to create a type-level language for defining table schemas "as a type",+queries that operate on those schemas, and, tangentially, "backends" that+can do something useful with those types like talk to an actual database.+++Using Ribbit, you might expect to see something like this:++```haskell+type PeopleTable =+  Field "id" Int+  :> Field "name" Text+  :> Field "age" Int+  ++type MyQuery = Select '["id", "name"] `From` PeopleTable `Where` "age" `Equals` (?)++matchingPeople <-+  query+    dbConn+    (Proxy :: Proxy MyQuery)+    (Only 21) -- argument that fills in the (?) placeholder++  :: IO [Only Int :> Only Text]++```++## Status++The status of Ribbit is non-functional pre-alpha. My goal though is to+make sure it is absolutely production ready for the operations it ends+up supporting, but we are a long way from that at the moment.++## How it compares with other libraries.++The short answer is there are a lot of other libraries and I'm not sure.+Persistent and esquelleto are ones I've used, but if you search "relational" or+"sql" in Hackage there seems to be a lot of other options. Part of the goals+for this library are to flesh out this approach myself, so I can have a better+context for understanding everything else available. In other words, it is part+research project. With that in mind, there are at least a couple of specific+goals I have in mind:++- Avoid template Haskell. Persistent is amazing, but the use of Template+  Haskell makes certain things difficult, like documenting (or for large+  projects even understanding) everything that is produced by the Template+  Haskell.++- Make the language easy to understand. If you have some basic SQL knowledge,+  it should be immediately obvious what is going on even if you are a beginner+  Haskeller.++- Try to make as much stuff happen at the type level as possible. The ability+  to write your own type classes or type families over Servant API types is, I feel,+  part of what makes Servant so amazing. I want to replicate that success here.+  So, for instance, if someone somewhere defines a schema type that looks like+  this:++  ```haskell+  type MySchema =+    Field "id" Int+    :> Field "name" Text+    :> Field "address" (Maybe Text)+  ```++  Then you would be free to deconstruct this type (using type families),+  transform it into another schema, generate customized `CREATE TABLE`+  statements if the (forthcoming) ones provided aren't good enough for your+  back-end or use case... that sort of thing. As a somewhat contrived example,+  maybe, for who knows what reason, you never want to allow null values in your+  database. You can write a type family that can inspect every field in an+  arbitrary schema, replacing all the `Maybe a` with just `a`, like:++  ```haskell+  -- With -XPolyKinds+  type family NoNulls schema where+    NoNulls (Field name (Maybe typ)) = Field name typ+    NoNulls (a :> b) = NoNulls a :> NoNulls b+    NoNulls a = a++  NoNulls MySchema +  -- Same as:+  --   Field "id" Int+  --   :> Field "name" Text+  --   :> Field "address" Text <--- note the lack of Maybe+  ```+++## The name: Ribbit++The name means nothing except I kindof like the sound of it. There are so many+"sql", "relational", "query", etc. package names already that I didn't want to:++1) get lost in the mix.+2) step on anyone's toes by choosing too similar a name.+3) create confusion by seeming to be associated with some other package with+   which I am not.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ribbit.cabal view
@@ -0,0 +1,31 @@++name:                ribbit+version:             0.1.0.0+synopsis:            ribbit+-- description:         +homepage:            https://github.com/owensmurray/ribbit+license:             MIT+license-file:        LICENSE+author:              Rick Owens+maintainer:          rick@owensmurray.com+copyright:           2019 Owens Murray, LLC.+-- category:            +build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  exposed-modules:     +    Database.Ribbit+    Database.Ribbit.PostgreSQL+  -- other-modules:       +  -- other-extensions:    +  build-depends:+    Only              >= 0.1     && < 0.2,+    base              >= 4.12    && < 4.13,+    om-show           >= 0.1.1.0 && < 0.2,+    postgresql-simple >= 0.6.2   && < 0.7,+    text              >= 1.2.3.1 && < 1.3+  hs-source-dirs:      src+  default-language:    Haskell2010+
+ src/Database/Ribbit.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+++{- | No documentation yet. See README for now. -}+module Database.Ribbit (+  Select,+  From,+  X,+  Where,+  As,+  Equals,+  (:>)(..),+  ReflectRelation(..),+  Render(..),+  ArgsType,+  ResultType,+  Field,+  And,+  Or,+  type (?),+) where+++import Data.Proxy (Proxy(Proxy))+import Data.Text (Text)+import Data.Tuple.Only (Only(Only))+import GHC.TypeLits (symbolVal, KnownSymbol, TypeError,+  ErrorMessage((:<>:), (:$$:), ShowType), AppendSymbol)+import qualified Data.Text as T+import qualified GHC.TypeLits as Lit+++{-+  Select+    '[Foo :> "foo", Bar :> "bar"]+  `From` Foo `X` Bar+  `Where`+    Foo :> id `Equals` Bar :> "foo_id"+    `And` Foo :> "baz" `Equals` (?)+-}++class Render query where+  render :: proxy query -> Text++{- SELECT -}+instance (Render fields) => Render (Select fields) where+  render _proxy =+    "SELECT "+    <> render (Proxy @fields)++{- Field list -}+instance {-# OVERLAPS #-} (KnownSymbol field) => Render '[field] where+  render _proxy = T.pack $ symbolVal (Proxy @field)+instance (KnownSymbol field, Render more) => Render (field:more) where+  render _proxy =+    T.pack (symbolVal (Proxy @field)) <>  ", " <> render (Proxy @more)++{- FROM -}+instance (Render proj, ReflectRelation relation) => Render (From proj relation) where+  render _proxy =+    render (Proxy @proj)+    <> " FROM "+    <> reflectRelation (Proxy @relation)++{- WHERE -}+instance (Render query, Render conditions) => Render (Where query conditions) where+  render _proxy =+    render (Proxy @query)+    <> " WHERE "+    <> render (Proxy @conditions)++{- Equals -}+instance (Render (Expr l), Render (Expr r)) => Render (Equals l r) where+  render _proxy =+    render (Proxy @(Expr l))+    <> " = "+    <> render (Proxy @(Expr r))++{- AND -}+instance (Render l, Render r) => Render (And l r) where+  render _proxy =+    "( "+    <> render (Proxy @l)+    <> " AND "+    <> render (Proxy @r)+    <> " )"++{- OR -}+instance (Render l, Render r) => Render (Or l r) where+  render _proxy =+    "( "+    <> render (Proxy @l)+    <> " AND "+    <> render (Proxy @r)+    <> " )"++{- Expr -}+instance Render (Expr (?)) where+  render _proxy = "?"+instance (KnownSymbol a) => Render (Expr a) where+  render _proxy = T.pack (symbolVal (Proxy @a))++{- (?) -}+instance Render (?) where+  render _proxy = "?"+++data Select fields++data From proj relation+infixl 6 `From`++data Where query conditions+infixl 6 `Where`++data Equals l r+infix 9 `Equals`++data And l r+infixr 8 `And`++data Or l r+infixr 7 `Or`++data Field name typ++data X l r+infixr 7 `X`++data As relation name+infix 8 `As`++data a :> b = a :> b+  deriving (Eq, Ord, Show)+infixr 5 :>++data (?)++data Expr a++type family ProjectionType proj schema where+  ProjectionType '[name] (Field name typ) = Only typ+  ProjectionType '[name] (Field name2 typ) =+    TypeError (+      'Lit.Text "name ("+      ':<>: 'ShowType name+      ':<>: 'Lit.Text ") not found in relation."+    )+  ProjectionType '[name] (Field name typ :> _) = Only typ+  ProjectionType '[name] (_ :> more) = ProjectionType '[name] more++  ProjectionType (name:more) relation =+    ProjectionType '[name] relation :> ProjectionType more relation++class ReflectRelation relation where+  type DBSchema relation+  reflectRelation :: proxy relation -> Text+++{- | Cross product -}+instance (ReflectRelation l, ReflectRelation r, KnownSymbol lname, KnownSymbol rname) => ReflectRelation (l `As` lname `X` r `As` rname) where+  type DBSchema (l `As` lname `X` r `As` rname) =+    AliasAs lname (DBSchema l)+    :> AliasAs rname (DBSchema r)+  reflectRelation _prxoy =+    reflectRelation (Proxy @l)+    <> " as "+    <> T.pack (symbolVal (Proxy @lname))+    <> ", "+    <> reflectRelation(Proxy @r)+    <> " as "+    <> T.pack (symbolVal (Proxy @rname))++type family AliasAs prefix schema where+  AliasAs prefix (Field name typ) =+    Field+      (prefix `AppendSymbol` "." `AppendSymbol` name)+      typ+  AliasAs prefix (Field name typ :> more) =+    Field+      (prefix `AppendSymbol` "." `AppendSymbol` name)+      typ+    :> AliasAs prefix more+++class TestVal a where+  testVal :: a++instance (TestVal a, TestVal b) => TestVal (a :> b) where+  testVal = testVal :> testVal+instance TestVal (Only Int) where+  testVal = Only 0+instance TestVal (Only Text) where+  testVal = Only "foo"+++type family ResultType query where+  ResultType (Select fields `From` relation) =+    ProjectionType fields (DBSchema relation)+  ResultType (query `Where` conditions) = ResultType query+  ResultType query =+    TypeError ('Lit.Text "Malformed Query" ':$$: 'ShowType query)++type family ArgsType query where+  ArgsType (_ `From` relation `Where` conditions) =+    ArgsType (DBSchema relation, conditions)+  ArgsType (schema, And a b) =+    StripUnit (Flatten (ArgsType (schema, a) :> ArgsType (schema, b)))+  ArgsType (schema, Or a b) =+    StripUnit (Flatten (ArgsType (schema, a) :> ArgsType (schema, b)))+  ArgsType (schema, Equals field (?)) =+    ProjectionType '[field] schema+  ArgsType _ = ()++type family Flatten a where+  Flatten ((a :> b) :> c) = Flatten (a :> b :> c)+  Flatten (a :> b) = a :> Flatten b+  Flatten a = a++type family StripUnit a where+  StripUnit (() :> a) = StripUnit a+  StripUnit (a :> ()) = StripUnit a+  StripUnit (a :> b) = a :> StripUnit b+  StripUnit a = a++
+ src/Database/Ribbit/PostgreSQL.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}++{- | "postgresql-simple"-backed query ribbit implementation. -}+module Database.Ribbit.PostgreSQL (+  query,+) where+++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Proxy (Proxy)+import Data.String (fromString)+import Data.Tuple.Only (Only(Only))+import Database.PostgreSQL.Simple (Connection)+import Database.PostgreSQL.Simple.FromField (FromField)+import Database.PostgreSQL.Simple.ToField (Action, ToField)+import Database.Ribbit (Render, render, ArgsType, ResultType, (:>)((:>)))+import qualified Data.Text as T+import qualified Database.PostgreSQL.Simple as PG+import qualified Database.PostgreSQL.Simple.FromRow as PGF+import qualified Database.PostgreSQL.Simple.ToRow as PGT+++query :: (+    MonadIO m,+    Render query,+    ToRow (ArgsType query),+    FromRow (ResultType query)+  )+  => Connection+  -> Proxy query+  -> ArgsType query+  -> m [ResultType query]+query conn theQuery args =+  liftIO . (fmap . fmap) unWrap $+    PG.query+      conn +      ((fromString . T.unpack . render) theQuery)+      (Wrap args)+++{- | Like 'PGF.FromRow', but defined here so we can avoid orphaned instances. -}+class FromRow a where+  fromRow :: PGF.RowParser a+instance (FromRow a, FromRow b) => FromRow (a :> b) where+  fromRow = +    (:>)+      <$> fromRow+      <*> fromRow+instance (FromField a) => FromRow (Only a) where+  fromRow = Only <$> PGF.field+++{- | Like 'PGT.ToRow', but defined here to avoid orphan instances. -}+class ToRow a where+  toRow :: a -> [Action]+instance (ToRow a, ToRow b) => ToRow (a :> b) where+  toRow (a :> b) = toRow a ++ toRow b+instance (ToField a) => ToRow (Only a) where+  toRow = PGT.toRow+++{- | Wrapper that helps us avoid orphan instances. -}+newtype Wrap a = Wrap {+    unWrap :: a+  }+instance (FromRow a) => PGF.FromRow (Wrap a) where+  fromRow = Wrap <$> fromRow+instance (ToRow a) => PGT.ToRow (Wrap a) where+  toRow = toRow . unWrap++