haskell timer

timer.hs

import System.Environment
import System.Directory 
import Control.Monad 
import Database.HDBC
import Database.HDBC.Sqlite3
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Format
import System.Locale
import Text.Printf

commands :: [(String, Connection -> [String] -> IO ())]
commands = [ ("add", add)
           , ("list", list)
           , ("rm", remove)
           ]

main = 
    do let dbFile = "timer.db"
       dbExists <- doesFileExist dbFile
       conn <- connectSqlite3 dbFile
       when (not dbExists) $ setupDb conn
       args <- getArgs
       if length args == 0
           then putStrLn usage
           else do
                   (cmd:args) <- getArgs
                   let mb = lookup cmd commands
                   runCommand mb conn cmd args
                   disconnect conn
                where runCommand Nothing _ cmd _ = 
                          putStrLn $ "Unknown command: " ++ cmd
                      runCommand (Just action) conn _ args = action conn args
                      usage =  "Usage: <command> [args]\n"
                            ++ "\nCOMMANDS"
                            ++ "\nadd <title> <date>    add new entry; date format: YYYY-MM-DD"
                            ++ "\nlist [<search>]       list entries; optional search param"
                            ++ "\nrm <id>               remove entry by id\n"
    
setupDb conn = 
    do run conn createTable []
       commit conn
       putStrLn "database created"
       return ()
    where createTable =  "CREATE TABLE entries " 
                      ++ "(id INTEGER PRIMARY KEY, " 
                      ++ "title VARCHAR(255) NOT NULL, " 
                      ++ "created DATETIME NOT NULL)"
           
add conn args = 
    if length args /= 2
    then putStrLn "invalid arguments for \"add\", expected: <title> <date>"
    else do let date = parseDate $ args !! 1
            if date == Nothing 
            then putStrLn "invalid date format, must be <YYYY-MM-DD>" 
            else do run conn 
                        "INSERT INTO entries (title, created) VALUES (?,?)"
                        [ toSql $ args !! 0, toSql date ]
                    commit conn
                    return ()
         where parseDate :: String -> Maybe Day
               parseDate = parseTime defaultTimeLocale "%F"
              
list conn args = 
    do 
       let search = if length args > 0 
           then " WHERE title LIKE '%" ++ args !! 0 ++ "%'" 
           else ""
       res <- quickQuery' conn
                         ("SELECT id, title, created FROM entries " ++ search ++ " ORDER BY id")
                         []
       curTime <- getCurrentTime
       let curDay = utctDay curTime
       let rows = map (rowToStr curDay) res
       mapM_ putStrLn rows
    where rowToStr :: Day -> [SqlValue] -> String
          rowToStr day [sid, stitle, screated] =
              toStr id title dayDiff created
              where id = (fromSql sid)::Integer
                    title = fromSql stitle
                    created = fromSql screated 
                    dayDiff = diffDays day created
                    toStr :: Integer -> String -> Integer -> Day -> String
                    toStr i t d c =
                        printf "%2d: %-40s %4d days - %s" 
                               i t d (show c)
                      
remove conn args =
    if length args /= 1
    then putStrLn "invalid arguments for \"rm\", expected: <id>"
    else do let id = parseId (args !! 0)
            case id of
                [(id,"")] -> rm id
                _ -> putStrLn "invalid id, must be integer"
         where parseId arg = reads arg :: [(Integer,String)]
               rm id = do num <- run conn 
                                     "DELETE FROM entries WHERE id = ?"
                                     [toSql id]
                          if num == 1
                              then printf "removed entry %d\n" id
                              else printf "entry %d does not exist\n" id
                          commit conn