Only allow valid code to be loaded from the DB
[L-seed.git] / src / Lseed / DB.hs
1 module Lseed.DB 
2         ( DBCode(..)
3         , getCodeToRun
4         , getUpdatedCodeFromDB
5         , addFinishedSeasonResults
6         ) where
7
8 import Database.HDBC
9 import Database.HDBC.ODBC
10 import Data.Map((!))
11 import qualified Data.Map as M
12
13 import Lseed.Data
14 import Lseed.Data.Functions
15 import Data.Maybe
16
17 data DBCode = DBCode
18         { dbcUserName :: String
19         , dbcUserID :: Integer
20         , dbcPlantName :: String
21         , dbcPlantID :: Integer
22         , dbcCode :: String
23         }
24         deriving (Show)
25
26 withLseedDB :: FilePath -> (Connection -> IO t) -> IO t
27 withLseedDB conf what = do
28         dn <- readFile conf
29         conn <- connectODBC dn  
30         res <- what conn
31         disconnect conn
32         return res
33
34 getCodeToRun :: FilePath -> IO [DBCode]
35 getCodeToRun conf = withLseedDB conf $ \conn -> do
36         let getCodeQuery = "SELECT plant.ID AS plantid, user.ID AS userid, code, plant.Name AS plantname, user.Name AS username from plant, user WHERE plant.Valid AND user.NextSeed = plant.ID;"
37         stmt <- prepare conn getCodeQuery
38         execute stmt []
39         result <- fetchAllRowsMap' stmt
40         return $ flip map result $ \m -> 
41                 DBCode (fromSql (m ! "username"))
42                        (fromSql (m ! "userid"))
43                        (fromSql (m ! "plantname"))
44                        (fromSql (m ! "plantid"))
45                        (fromSql (m ! "code"))
46
47 getUpdatedCodeFromDB :: FilePath -> Integer -> IO (Maybe DBCode)
48 getUpdatedCodeFromDB conf userid = withLseedDB conf $ \conn -> do
49         let query = "SELECT plant.ID AS plantid, user.ID AS userid, code, plant.Name AS plantname, user.Name AS username from plant, user WHERE plant.Valid AND user.NextSeed = plant.ID AND user.ID = ?;"
50         stmt <- prepare conn query
51         execute stmt [toSql userid]
52         result <- fetchAllRowsMap' stmt
53         return $ listToMaybe $ flip map result $ \m -> 
54                 DBCode (fromSql (m ! "username"))
55                        (fromSql (m ! "userid"))
56                        (fromSql (m ! "plantname"))
57                        (fromSql (m ! "plantid"))
58                        (fromSql (m ! "code"))
59
60 addFinishedSeasonResults conf garden = withLseedDB conf $ \conn -> do 
61         let owernerscore = M.toList $ foldr go M.empty garden
62                 where go p = M.insertWith (+) (plantOwner p) (plantLength (phenotype p))
63         run conn "INSERT INTO season VALUES (NULL, False)" []
64         stmt <- prepare conn "SELECT LAST_INSERT_ID()"
65         execute stmt []
66         id <- (head . head) `fmap` fetchAllRows' stmt
67         stmt <- prepare conn "INSERT INTO seasonscore VALUES (NULL, ?, ?, ?)"
68         executeMany stmt $ map (\(o,l)->
69                 [ toSql $ o
70                 , id
71                 , toSql $ l
72                 ]) owernerscore
73