From 4ecb9e0bbb6f955ec645bb83e74a75d605d837f2 Mon Sep 17 00:00:00 2001
From: Luke Taylor <tekul.hs@gmail.com>
Date: Wed, 29 Mar 2017 23:26:18 +0100
Subject: [PATCH] Get Hasql working for Story data type

Works for storing and retrieving all the story data.

Dealing with the composite list of dictionary entries is a bit tricky when
doing an insert/update and requires a workaround where the entry is unzipped
into arrays and then recombined in the SQL and cast to the dict_entry type.
See https://github.com/nikita-volkov/hasql/issues/65 for more information.
---
 api/Api/Types.hs |  7 ++---
 api/HasqlDB.hs   | 66 ++++++++++++++++++++++++++++++++++++++++++++++++
 my3ml.cabal      |  5 ++++
 pgdb.sql         | 11 +++++---
 4 files changed, 82 insertions(+), 7 deletions(-)
 create mode 100644 api/HasqlDB.hs

diff --git a/api/Api/Types.hs b/api/Api/Types.hs
index 612ad54..96ea4cb 100644
--- a/api/Api/Types.hs
+++ b/api/Api/Types.hs
@@ -19,13 +19,14 @@ import           Servant ((:<|>), (:>), AuthProtect, Capture, ReqBody, Post, Get
 
 data Story = Story
     { id :: Maybe StoryId
-    , img :: Text
     , title :: Text
-    , tags :: [Text]
+    , img :: Text
     , level :: Int
+    , curriculum :: Text
+    , tags :: [Text]
+    , content :: Text
     , words :: [DictEntry]
     , date :: UTCTime
-    , content :: Text
     } deriving (Show, Generic, ElmType, ToJSON, FromJSON)
 
 data DictEntry = DictEntry
diff --git a/api/HasqlDB.hs b/api/HasqlDB.hs
new file mode 100644
index 0000000..3ef077c
--- /dev/null
+++ b/api/HasqlDB.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+module HasqlDB where
+
+import           Control.Monad (replicateM)
+import           Data.Functor.Contravariant
+import           Data.List (foldl')
+import           Data.Maybe (fromJust)
+import           Data.Monoid
+import           Data.Text (Text)
+import           Data.Vector (Vector)
+import           Hasql.Query (Query)
+import qualified Hasql.Query as Q
+import qualified Hasql.Encoders as E
+import qualified Hasql.Decoders as D
+import           Prelude hiding (id, words)
+
+import Api.Types
+
+dvText :: D.Row Text
+dvText = D.value D.text
+
+evText :: E.Params Text
+evText = E.value E.text
+
+selectAllStories :: Query () (Vector Story)
+selectAllStories =
+    Q.statement sql mempty (D.rowsVector decoder) True
+  where
+    sql = "SELECT id, title, img_url, level, curriculum, tags, content, words, created_at FROM story"
+
+    dictEntryValue = D.composite (DictEntry <$> D.compositeValue D.text <*> (fromIntegral <$> D.compositeValue D.int2))
+    array v = D.value (D.array (D.arrayDimension replicateM (D.arrayValue v)))
+
+    decoder = Story
+        <$> (Just <$> dvText)
+        <*> dvText
+        <*> dvText
+        <*> (fromIntegral <$> D.value D.int2)
+        <*> dvText
+        <*> array D.text
+        <*> dvText
+        <*> array dictEntryValue
+        <*> D.value D.timestamptz
+
+insertStory :: Query Story ()
+insertStory = Q.statement sql storyEncoder D.unit True
+  where
+    sql = "INSERT INTO story (id, title, img_url, level, curriculum, tags, content, words) \
+                 \VALUES ($1, $2, $3, $4, $5, $6, $7, (array(select word::dict_entry from unnest ($8, $9) as word)))"
+
+storyEncoder :: E.Params Story
+storyEncoder =
+    contramap (fromJust . storyId) evText <>
+    contramap title evText <>
+    contramap img evText <>
+    contramap (fromIntegral . storyLevel) (E.value E.int4) <>
+    contramap curriculum evText <>
+    contramap tags (array E.text) <>
+    contramap content evText <>
+    contramap (map word . words) (array E.text) <>
+    contramap (map (fromIntegral . index) . words) (array E.int2)
+  where
+    array v = E.value (E.array (E.arrayDimension foldl' (E.arrayValue v)))
+    storyId = id :: Story -> Maybe Text
+    storyLevel = level :: Story -> Int
diff --git a/my3ml.cabal b/my3ml.cabal
index 76e42e5..8674a9c 100644
--- a/my3ml.cabal
+++ b/my3ml.cabal
@@ -21,10 +21,14 @@ library
   exposed-modules:     Api.Server
                      , Api.Types
                      , Api.Auth
+                     , HasqlDB
   build-depends:       aeson >= 0.8.0.2
                      , base >= 4.7 && < 5
+                     , bytestring
                      , containers >= 0.5.6.2
+                     , contravariant >= 1.4
                      , elm-export
+                     , hasql >= 0.19
                      , mtl
                      , servant-server >= 0.9
                      , stm >= 2.4.4
@@ -33,6 +37,7 @@ library
                      , transformers >= 0.4.2.0
                      , uuid
                      , wai
+                     , vector
   default-language:    Haskell2010
 
 executable backend
diff --git a/pgdb.sql b/pgdb.sql
index fe5adf5..50bb98b 100644
--- a/pgdb.sql
+++ b/pgdb.sql
@@ -1,5 +1,7 @@
 CREATE TYPE user_type AS ENUM ('student', 'teacher', 'admin');
 
+CREATE TYPE dict_entry AS (word text, index smallint);
+
 CREATE TABLE login
     ( id uuid PRIMARY KEY
     , username text NOT NULL UNIQUE CHECK (length(username) > 0)
@@ -11,12 +13,13 @@ CREATE TABLE login
 CREATE TABLE story
     ( id text PRIMARY KEY
     , title text NOT NULL
-    , level integer NOT NULL CHECK (level >= 0 AND level < 10)
+    , img_url text NOT NULL
+    , level smallint NOT NULL CHECK (level >= 0 AND level < 10)
     , curriculum text NOT NULL CHECK (length(curriculum) > 0)
     , tags text[] NOT NULL
-    , json jsonb NOT NULL
+    , content text NOT NULL CHECK (length(content) > 0)
+    , words dict_entry[] NOT NULL
     , created_at timestamptz NOT NULL DEFAULT CURRENT_TIMESTAMP
-    , updated_at timestamptz NOT NULL DEFAULT CURRENT_TIMESTAMP
     );
 
 CREATE TABLE school
@@ -44,7 +47,7 @@ CREATE TABLE student
     , sub uuid NOT NULL REFERENCES login
     , name text NOT NULL CHECK (length(name) > 0)
     , description text
-    , level integer NOT NULL CHECK (level >= 0 AND level < 10)
+    , level smallint NOT NULL CHECK (level >= 0 AND level < 10)
     , school_id uuid NOT NULL REFERENCES school
     );