Data-driven hacks

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RankNTypes #-}
module Database.PostgreSQL.Simple.Data where

import Blaze.ByteString.Builder
import Control.Exception
import Control.Monad
import Control.Monad.State
import Data.ByteString.UTF8 (fromString)
import Data.Char
import Data.Data
import Data.List
import Data.Maybe
import System.IO.Unsafe
import Database.PostgreSQL.Simple.ToField
import Prelude hiding (catch)

-- | The type used for encoding fields of a data type into an SQL
-- expression.
data Fields = Fields [String]
  deriving Show

-- | The type used for encoding the values of fields of a record type
-- into an SQL expression.
newtype Values = Values [Action]
  deriving Show

-- | Type used for encoding data type names as database entities.
newtype Name = Name String
  deriving Show

-- | This will encode, e.g. Foo { bar :: String, mu :: Int } to
-- bar,mu.
instance ToField Fields where
  toField (Fields fields) =
    Plain . buildString . intercalate "," $ map normalize fields

-- | This will encode, e.g. Foo { bar :: String, mu :: Int } to
-- bar,mu.
instance ToField Values where
  toField (Values actions) = Many (zipWith encode [0::Int ..] actions) where
    encode 0 value = toField value
    encode _ action = Many [Plain (buildString ","),toField action]

instance ToField Name where
  toField (Name i) = Plain (buildString i)

-- | Because stupid APIs.
buildString :: String -> Builder
buildString = fromWrite . writeByteString . fromString

-- | Generate a Fields representation of a data type, ready for
-- passing to a query/exec function.
dataInsertFields :: Data a => a -> Fields
dataInsertFields a = withConstructor a $ \cons -> Fields (constrFields cons)

-- | Generate a Fields representation of a data type, ready for
-- passing to a query/exec function.
dataInsertFieldsSans :: Data a => [String] -> a -> Fields
dataInsertFieldsSans sans a = withConstructor a $ \cons ->
  Fields (filter (not . flip elem sans) (constrFields cons))

-- | Generate a Fields representation of a data type, ready for
-- passing to a query/exec function.
dataSelectFields :: Data a => a -> Fields
dataSelectFields a = withConstructor a $ \cons -> Fields (constrFields cons)

-- | Generate the code for values.
dataValues :: Data a => a -> Values
dataValues a = withConstructor a $ \_ -> Values $ gmapQ convertValue a

-- | Generate the code for values, filtering on the given fields.
dataValuesSans :: Data a => [String] -> a -> Values
dataValuesSans sans a = withConstructor a $ \cons ->
  let fields = constrFields cons
      values = map snd (filter (not . flip elem sans . fst) (zip fields (gmapQ convertValue a)))
  in Values values

-- | Generate an entity name for a data type.
dataName :: Data a => a -> Name
dataName a = withConstructor a $ \cons -> Name (drop 1 (normalize (show cons)))

-- | Convert a value to an SQL-rendering action.
convertValue :: (forall d. Data d => d -> Action)
convertValue d =
  fromMaybe (error $ "Unable to convert value of type: " ++
                     show (dataTypeOf d))
            (foldr mplus
                   mzero
                   [go (ty :: Int)
                   ,go (ty :: Integer)
                   ,go (ty :: Double)
                   ,go (ty :: String)
                   ,go (ty :: Bool)
                   ,go (ty :: Maybe Int)
                   ,go (ty :: Maybe Integer)
                   ,go (ty :: Maybe Double)
                   ,go (ty :: Maybe String)
                   ,go (ty :: Maybe Bool)
                   ])

  where ty :: a
        ty = undefined

        go :: (Typeable f,ToField f) => f -> Maybe Action
        go = convert d

-- | Convert to a specific type.
convert :: (Data d,Typeable f,ToField f) => d -> f -> Maybe Action
convert d typ =
  case cast d of
    Nothing -> Nothing
    Just d' -> Just (toField (fst (d', [d',typ])))

-- | With an appropriate connector.
withConstructor :: Data a => a -> (Constr -> t) -> t
withConstructor a f =
  case dataTypeConstrs (dataTypeOf a) of
    []      -> error $ "No constructors for data type: " ++
                       show (dataTypeOf a)
    (_:_:_) -> error $ "Too many constructors for data type: " ++
                       show (dataTypeOf a)
    [cons]  -> case constrFields cons of
      []    -> error $ "Must be a record, but isn't: " ++
                       show (dataTypeOf a)
      _     -> f cons

-- | Normalize a Haskell name to an SQL name.
normalize :: [Char] -> [Char]
normalize = concatMap replace where
  replace c | isUpper c = "_" ++ [toLower c]
            | otherwise = [c]

newtype FieldName = FieldName String
  deriving (Typeable,Data,Show)
instance Exception FieldName

-- | Get a data type consisting of "described" fields.
dataDescribeFields :: Data a => a
dataDescribeFields = result where
  result = withConstructor result $ \cons ->
    evalState (fromConstrM (do fieldName:fields <- get
                               put fields
                               return (throw (FieldName fieldName)))
                           cons)
              (constrFields cons)

-- | Get the a record field.
dataField :: Data a => (a -> b) -> String
dataField f = unsafePerformIO $
  catch (let !_ = f dataDescribeFields in undefined)
        (\(FieldName name) -> return name)
3:1: Error: Unused LANGUAGE pragma
Found:
{-# LANGUAGE StandaloneDeriving #-}
Why not remove it.
91:14: Error: Use msum
Found:
foldr mplus mzero
Why not:
msum
116:31: Error: Evaluate
Found:
fst (d', [d', typ])
Why not:
d'
132:14: Warning: Use String
Found:
[Char] -> [Char]
Why not:
String -> String
134:27: Warning: Use :
Found:
"_" ++ [toLower c]
Why not:
'_' : [toLower c]

Experimental SQL interface based on this

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
--------------------------------------------------------------------------------
-- Experimental SQL interface

data Where a where
  (:=:) :: (Eq a,Eq b) => Where a -> Where b -> Where Bool
  And :: Where Bool -> Where Bool -> Where Bool
  Field :: (Field a) -> Where a
  Int :: Int -> Where Int
  Double :: Double -> Where Double
  String :: String -> Where String
  TRUE :: Where Bool
  FALSE :: Where Bool

data Field b = F String

data Submission =
  Submission { submissionId :: Int, submissionTitle :: String }
  deriving (Data,Typeable)

data Order = Desc String | Asc String

-- | Render a WHERE condition to a string.
whereToString :: Where a -> String
whereToString w = case w of
  String string -> "E'" ++ init (tail (show string)) ++ "'"
  Double i -> show i
  Int i -> show i
  a :=: b -> "(" ++ whereToString a ++ " = " ++ whereToString b ++ ")"
  And a b -> "(" ++ whereToString a ++ " AND " ++ whereToString b ++ ")"
  Field (F str) -> "\"" ++ normalize str ++ "\""
  TRUE -> "TRUE"
  FALSE -> "FALSE"

-- | Make a field expression.
field :: Data a => (a -> b) -> Where b
field f = Field (F (dataField f))

-- | Make a field expression.
desc :: Data a => (a -> b) -> Order
desc f = Desc (dataField f)

-- | Make a field expression.
asc :: Data a => (a -> b) -> Order
asc f = Asc (dataField f)

-- | Run a query.
query :: (Sql.ToRow q, Sql.FromRow r) => Sql.Query -> q -> Transaction [r]
query qry args = do
  conn <- ask
  liftIO $ Sql.query conn qry args

-- | Execute a query.
exec :: (Sql.ToRow q) => Sql.Query -> q -> Transaction Int64
exec qry args = do
  conn <- ask
  liftIO $ Sql.execute conn qry args

-- | Insert a data value entirely.
insert :: Data a => a -> Transaction Int64
insert d =
  exec "INSERT INTO ? (?) VALUES (?)"
       (dataName d
       ,dataInsertFields d
       ,dataValues d)

-- | Insert a value sans some fields.
insertSans :: Data a => [String] -> a -> Transaction Int64
insertSans sans d =
  exec "INSERT INTO ? (?) VALUES (?)"
       (dataName d
       ,dataInsertFieldsSans sans d
       ,dataValuesSans sans d)

-- | Select with a DSL query.
select :: (Data a,Sql.FromRow r) => a -> [Where Bool] -> [Order] -> Transaction [r]
select a w orders =
  query (fromString ("SELECT ? FROM ? WHERE " ++ whereToString (foldr And TRUE w) ++ showOrders orders))
        (dataSelectFields a,dataName a)

showOrders orders =
  case orders of
    [] -> ""
    orders' -> " ORDER BY " ++ (intercalate "," (map showOrdering orders'))

  where showOrdering (Desc e) = normalize e ++ " DESC"
        showOrdering (Asc e) = normalize e ++ " ASC"
7:12: Warning: Redundant bracket
Found:
(Field a) -> Where a
Why not:
Field a -> Where a
83:16: Warning: Redundant bracket
Found:
" ORDER BY " ++ (intercalate "," (map showOrdering orders'))
Why not:
" ORDER BY " ++ intercalate "," (map showOrdering orders')

Example of using experimental API

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

-- | The server.

module Server where

import Server.API
import Server.Migration
import SharedTypes

import Data.Maybe
import Database.PostgreSQL.Simple.Data
import Snap.Core
import Snap.Http.Server
import System.Environment

-- | Main entry point.
server :: IO ()
server = do
  args <- getArgs
  migrate (any (=="-create-version") args)
  httpServe (setPort 10002 defaultConfig) (route [("/json",handle dispatcher)])

-- | Dispatch on the commands.
dispatcher :: Command -> Dispatcher
dispatcher cmd =
  case cmd of
    NewTask task r -> r <~ do
      _ <- transaction $ insertSans [dataField taskId] task
      return OK
    Tasks r -> r <~ do
      fmap List $ transaction $ do
        returns $ \a -> do
          tasks <- select a [] [desc taskId]
          return (map (\(id,title,difficulty,tags,background,what,gohere) ->
                        Task id title difficulty tags background what gohere)
                      tasks)
    GetTask id r -> r <~ do
      transaction $ do
        returns $ \a -> do
          tasks <- select a [field taskId :=: Int id] []
          return (listToMaybe (map (\(id,title,difficulty,tags,background,what,gohere) ->
                                     Task id title difficulty tags background what gohere)
                                   tasks))
1:1: Error: Unused LANGUAGE pragma
Found:
{-# LANGUAGE ViewPatterns #-}
Why not remove it.
22:12: Error: Use elem
Found:
any (== "-create-version")
Why not:
elem "-create-version"
32:21: Error: Redundant do
Found:
do fmap List $
transaction $
do returns $
\ a ->
do tasks <- select a [] [desc taskId]
return
(map
(\ (id, title, difficulty, tags, background, what, gohere) ->
Task id title difficulty tags background what gohere)
tasks)
Why not:
fmap List $
transaction $
do returns $
\ a ->
do tasks <- select a [] [desc taskId]
return
(map
(\ (id, title, difficulty, tags, background, what, gohere) ->
Task id title difficulty tags background what gohere)
tasks)
33:33: Error: Redundant do
Found:
do returns $
\ a ->
do tasks <- select a [] [desc taskId]
return
(map
(\ (id, title, difficulty, tags, background, what, gohere) ->
Task id title difficulty tags background what gohere)
tasks)
Why not:
returns $
\ a ->
do tasks <- select a [] [desc taskId]
return
(map
(\ (id, title, difficulty, tags, background, what, gohere) ->
Task id title difficulty tags background what gohere)
tasks)
39:26: Error: Redundant do
Found:
do transaction $
do returns $
\ a ->
do tasks <- select a [field taskId :=: Int id] []
return
(listToMaybe
(map
(\ (id, title, difficulty, tags, background, what, gohere) ->
Task id title difficulty tags background what gohere)
tasks))
Why not:
transaction $
do returns $
\ a ->
do tasks <- select a [field taskId :=: Int id] []
return
(listToMaybe
(map
(\ (id, title, difficulty, tags, background, what, gohere) ->
Task id title difficulty tags background what gohere)
tasks))
40:21: Error: Redundant do
Found:
do returns $
\ a ->
do tasks <- select a [field taskId :=: Int id] []
return
(listToMaybe
(map
(\ (id, title, difficulty, tags, background, what, gohere) ->
Task id title difficulty tags background what gohere)
tasks))
Why not:
returns $
\ a ->
do tasks <- select a [field taskId :=: Int id] []
return
(listToMaybe
(map
(\ (id, title, difficulty, tags, background, what, gohere) ->
Task id title difficulty tags background what gohere)
tasks))

Data type is defined like this

1
2
3
4
5
6
7
8
9
data Task = Task { taskId             :: Int
                 , taskTitle          :: String
                 , taskDifficulty     :: String
                 , taskTags           :: String
                 , taskBackground     :: String
                 , taskWhatNeedsDoing :: String
                 , taskGoHere         :: String
                 }
  deriving (Show,Data,Typeable)