~manuel-uberti/gpwh

10deda003fcccfdefafd8e1bf89d8fd32f966fab — Manuel Uberti 4 months ago 7cc9522
Add lesson 41
M gpwh.cabal => gpwh.cabal +2 -0
@@ 30,5 30,7 @@ library
    , http-types
    , random
    , split
    , sqlite-simple
    , text
    , time
  default-language: Haskell2010

M package.yaml => package.yaml +2 -0
@@ 27,6 27,8 @@ dependencies:
- aeson
- http-conduit
- http-types
- sqlite-simple
- time
  
library:
  source-dirs: src

A src/lesson_41/build_db.sql => src/lesson_41/build_db.sql +29 -0
@@ 0,0 1,29 @@
DROP TABLE IF EXISTS checkedout;
DROP TABLE IF EXISTS tools;
DROP TABLE IF EXISTS users;

CREATE TABLE users (
       id INTEGER PRIMARY KEY,
       username TEXT
);

CREATE TABLE tools (
       id INTEGER PRIMARY KEY,
       name TEXT,
       description TEXT,
       lastReturned TEXT,
       timesBorrowed INTEGER
);

CREATE TABLE checkedout (
       user_id INTEGER,
       tool_id INTEGER
);

INSERT INTO users (username) VALUES ('willkurt');

INSERT INTO tools (name,description,lastReturned,timesBorrowed)
VALUES ('hammer','hits stuff','2017-01-01',0);

INSERT INTO tools (name,description,lastReturned,timesBorrowed)
VALUES ('saw','cuts stuff','2017-01-01',0);

A src/lesson_41/qc.hs => src/lesson_41/qc.hs +10 -0
@@ 0,0 1,10 @@
-- 41.1
-- mconcat is preferred over ++ because it makes it easier to refactor with text
-- types.

-- 41.3
-- We need two functions because there is no &rest (i.e., variable number of
-- arguments) in Haskell.

-- 41.4
-- >>= needs a function taking an argument on its right side.

A src/lesson_41/tools.hs => src/lesson_41/tools.hs +233 -0
@@ 0,0 1,233 @@
{-# LANGUAGE OverloadedStrings #-}

module Tools where

import Control.Applicative
import qualified Data.Text as T
import Data.Time
import Database.SQLite.Simple
import Database.SQLite.Simple.FromRow

data Tool = Tool
  { toolId :: Int,
    name :: String,
    description :: String,
    lastReturned :: Day,
    timesBorrowed :: Int
  }

data User = User
  { userId :: Int,
    userName :: String
  }

instance Show User where
  show user =
    mconcat
      [ show $ userId user,
        ".) ",
        userName user
      ]

instance Show Tool where
  show tool =
    mconcat
      [ show $ toolId tool,
        ".) ",
        name tool,
        "\n description: ",
        description tool,
        "\n last returned: ",
        show $ lastReturned tool,
        "\n times borrowed: ",
        show $ timesBorrowed tool,
        "\n"
      ]

withConn :: String -> (Connection -> IO ()) -> IO ()
withConn dbName action = do
  conn <- open dbName
  action conn
  close conn

addUser :: String -> IO ()
addUser userName = do
  -- QC 41.2
  withConn "tools.db" $
    \conn -> execute conn "INSERT INTO users (username) VALUES (?)" (Only userName)
  print "user added"

-- Q41.1
addTool :: String -> String -> IO ()
addTool toolName toolDescription = do
  withConn "tools.db" $
    \conn -> do
      currentDay <- utctDay <$> getCurrentTime
      let timesBorrowed = 0 :: Int
      execute
        conn
        "INSERT INTO tools (name,description,lastReturned,timesBorrowed) VALUES (?,?,?,?);"
        (toolName, toolDescription, currentDay, timesBorrowed)
  print "tool added"

checkout :: Int -> Int -> IO ()
checkout userId toolId =
  withConn "tools.db" $
    \conn ->
      execute
        conn
        "INSERT INTO checkedout (user_id,tool_id) VALUES (?,?)"
        (userId, toolId)

instance FromRow User where
  fromRow =
    User
      <$> field
      <*> field

instance FromRow Tool where
  fromRow =
    Tool
      <$> field
      <*> field
      <*> field
      <*> field
      <*> field

printUsers :: IO ()
printUsers =
  withConn "tools.db" $
    \conn -> do
      resp <- query_ conn "SELECT * FROM users;" :: IO [User]
      mapM_ print resp

printToolQuery :: Query -> IO ()
printToolQuery q =
  withConn "tools.db" $
    \conn -> do
      resp <- query_ conn q :: IO [Tool]
      mapM_ print resp

printTools :: IO ()
printTools = printToolQuery "SELECT * FROM tools;"

printAvailable :: IO ()
printAvailable =
  printToolQuery $
    mconcat
      [ "SELECT * FROM tools ",
        "WHERE id NOT IN ",
        "(SELECT tool_id FROM checkedout);"
      ]

printCheckedout :: IO ()
printCheckedout =
  printToolQuery $
    mconcat
      [ "SELECT * FROM tools ",
        "WHERE id IN ",
        "(SELECT tool_id FROM checkedout);"
      ]

firstOrNothing :: [a] -> Maybe a
firstOrNothing [] = Nothing
firstOrNothing (x : _) = Just x

selectTool :: Connection -> Int -> IO (Maybe Tool)
selectTool conn toolId = do
  resp <-
    query conn "SELECT * FROM tools WHERE id = (?)" (Only toolId) :: IO [Tool]
  return $ firstOrNothing resp

updateTool :: Tool -> Day -> Tool
updateTool tool date =
  tool
    { lastReturned = date,
      timesBorrowed = 1 + timesBorrowed tool
    }

updateOrWarn :: Maybe Tool -> IO ()
updateOrWarn Nothing = print "id not found"
updateOrWarn (Just tool) =
  withConn "tools.db" $
    \conn -> do
      let q =
            mconcat
              [ "UPDATE tools SET ",
                "lastReturned = ?, ",
                "timesBorrowed = ? ",
                "WHERE id = ?;"
              ]
      execute conn q (lastReturned tool, timesBorrowed tool, toolId tool)
      print "tool updated"

updateToolTable :: Int -> IO ()
updateToolTable toolId =
  withConn "tools.db" $
    \conn -> do
      tool <- selectTool conn toolId
      currentDay <- utctDay <$> getCurrentTime
      let updatedTool = updateTool <$> tool <*> pure currentDay
      updateOrWarn updatedTool

checkin :: Int -> IO ()
checkin toolId =
  withConn "tools.db" $
    \conn -> do
      execute
        conn
        "DELETE FROM checkedout WHERE tool_id = (?);"
        (Only toolId)

checkinAndUpdate :: Int -> IO ()
checkinAndUpdate toolId = do
  checkin toolId
  updateToolTable toolId

promptAndAddUser :: IO ()
promptAndAddUser = do
  print "Enter new user name"
  userName <- getLine
  addUser userName

-- Q41.2
promptAndAddTool :: IO ()
promptAndAddTool = do
  print "Enter new tool name"
  toolName <- getLine
  print "Enter new tool description"
  toolDescription <- getLine
  addTool toolName toolDescription

promptAndCheckout :: IO ()
promptAndCheckout = do
  print "Enter the id of the user"
  userId <- read <$> getLine
  print "Enter the id of the tool"
  toolId <- read <$> getLine
  checkout userId toolId

promptAndCheckin :: IO ()
promptAndCheckin = do
  print "Enter the id of the tool"
  toolId <- read <$> getLine
  checkinAndUpdate toolId

performCommand :: String -> IO ()
performCommand command
  | command == "users" = printUsers >> main
  | command == "tools" = printTools >> main
  | command == "addUser" = promptAndAddUser >> main
  | command == "addTool" = promptAndAddTool >> main -- Q41.2
  | command == "checkout" = promptAndCheckout >> main
  | command == "checkin" = promptAndCheckin >> main
  | command == "in" = printAvailable >> main
  | command == "out" = printCheckedout >> main
  | command == "quit" = print "bye!"
  | otherwise = print "Sorry command not found" >> main

main :: IO ()
main = do
  print "Enter a command"
  command <- getLine
  performCommand command

M stack.yaml => stack.yaml +5 -0
@@ 97,6 97,7 @@ extra-deps:
- scientific-0.3.7.0@sha256:76465a82beb2af6ea83ebd00684acc0ffe659e7da7066329931dc8f02fc97507,4826
- semialign-1.2.0.1@sha256:2ab22ab4f7e67028a745e549ae49f1ddecbd83e62d7e6ecce4ab0685410da536,2836
- semigroupoids-5.3.7@sha256:fb1a86c250997c269106645724a67bc358235245cf385b589f855ac070d4ada0,7488
- sqlite-simple-0.4.18.2@sha256:dda1643e723591c880dda8eeba73e93502cfa775078a79da55b5efec4c52ff66,3028
- socks-0.6.1@sha256:ac190808eea704672df18f702e8f2ad0b7a4d0af528e95ee55ea6ee0be672e2a,1258
- split-0.2.3.4@sha256:a6df9c3e806ee7cb50bc980a183fc1156f35022a39430dabac0bf9456fe18a4b,2647
- splitmix-0.1.0.4@sha256:714a55fd28d3e2533bd5b49e74f604ef8e5d7b06f249c8816f6c54aed431dcf1,6483


@@ 123,6 124,10 @@ extra-deps:
- x509-system-1.6.7@sha256:45ddd5db19f18be80614e058e8838765f2749a8afcfd2b292bd6afb36820a3c0,1492
- x509-validation-1.6.12@sha256:4f4af20ec77f02c042ecd4726c195bb0e0b694b336de81e7bd4515b2917bd9bc,2169
- zlib-0.6.3.0@sha256:8214a9d37580f17f8b675109578a5dbe6853559eef156e34dc2233f1123ace33,5216
- Only-0.1@sha256:f92f5da97e647451f1ee7f5bf44914fb75062d08ccd3f36b2000d649c63d13aa,1373
- blaze-textual-0.2.2.1@sha256:42ab6bfe5b4ad4e703d2f55fcf6e67c6e561e7defc563723ca5978d4c78468bf,2573
- direct-sqlite-2.3.27@sha256:94207d3018da3bda84bc6ce00d2c0236ced7edb37afbd726ed2a0bfa236e149b,3771
- old-locale-1.0.0.7@sha256:fa998be2c7e00cd26a6e9075bea790caaf3932caa3e9497ad69bc20380dd6911,1071

# Override default flag values for local packages and extra-deps
# flags: {}

M stack.yaml.lock => stack.yaml.lock +35 -0
@@ 397,6 397,13 @@ packages:
  original:
    hackage: semigroupoids-5.3.7@sha256:fb1a86c250997c269106645724a67bc358235245cf385b589f855ac070d4ada0,7488
- completed:
    hackage: sqlite-simple-0.4.18.2@sha256:dda1643e723591c880dda8eeba73e93502cfa775078a79da55b5efec4c52ff66,3028
    pantry-tree:
      size: 1930
      sha256: 64443740f279b344aecb3389ec8f69ea04d171916a9ed23f8fa529dd3ae75540
  original:
    hackage: sqlite-simple-0.4.18.2@sha256:dda1643e723591c880dda8eeba73e93502cfa775078a79da55b5efec4c52ff66,3028
- completed:
    hackage: socks-0.6.1@sha256:ac190808eea704672df18f702e8f2ad0b7a4d0af528e95ee55ea6ee0be672e2a,1258
    pantry-tree:
      size: 692


@@ 578,4 585,32 @@ packages:
      sha256: 87b7fd16379d679eb01d9fae78b4db97356d301fce4a040ba9e690d16eeb98b2
  original:
    hackage: zlib-0.6.3.0@sha256:8214a9d37580f17f8b675109578a5dbe6853559eef156e34dc2233f1123ace33,5216
- completed:
    hackage: Only-0.1@sha256:f92f5da97e647451f1ee7f5bf44914fb75062d08ccd3f36b2000d649c63d13aa,1373
    pantry-tree:
      size: 210
      sha256: e999ae7690fc1e13bb471bc1ead6d7a5c245843d17862d3d27f7f0f752513257
  original:
    hackage: Only-0.1@sha256:f92f5da97e647451f1ee7f5bf44914fb75062d08ccd3f36b2000d649c63d13aa,1373
- completed:
    hackage: blaze-textual-0.2.2.1@sha256:42ab6bfe5b4ad4e703d2f55fcf6e67c6e561e7defc563723ca5978d4c78468bf,2573
    pantry-tree:
      size: 557
      sha256: 2500c14c890976a24ca451d3f4f2389571886a48704562127a13e016b7635f81
  original:
    hackage: blaze-textual-0.2.2.1@sha256:42ab6bfe5b4ad4e703d2f55fcf6e67c6e561e7defc563723ca5978d4c78468bf,2573
- completed:
    hackage: direct-sqlite-2.3.27@sha256:94207d3018da3bda84bc6ce00d2c0236ced7edb37afbd726ed2a0bfa236e149b,3771
    pantry-tree:
      size: 770
      sha256: c7f5afe70db567e2cf9f3119b49f4b402705e6bd08ed8ba98747a64a8a0bef41
  original:
    hackage: direct-sqlite-2.3.27@sha256:94207d3018da3bda84bc6ce00d2c0236ced7edb37afbd726ed2a0bfa236e149b,3771
- completed:
    hackage: old-locale-1.0.0.7@sha256:fa998be2c7e00cd26a6e9075bea790caaf3932caa3e9497ad69bc20380dd6911,1071
    pantry-tree:
      size: 263
      sha256: 462ef15cb35164d585aa3860f717c9685fbf05578330490860abd544381d2e24
  original:
    hackage: old-locale-1.0.0.7@sha256:fa998be2c7e00cd26a6e9075bea790caaf3932caa3e9497ad69bc20380dd6911,1071
snapshots: []

A tools.db => tools.db +0 -0