<commit_before>{-# LANGUAGE OverloadedStrings #-}

import Control.Monad (liftM, msum, forM_)
import Control.Monad.IO.Class (liftIO)
import Data.Int (Int64)
import Data.Monoid (mconcat)
import Data.Time.Calendar (Day)
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Format (formatTime)
import Data.Time.LocalTime (LocalTime, utcToLocalTime, getCurrentTimeZone, TimeZone)
-- sudo apt-get install libmysqlclient-dev
-- cabal install mysql-simple
import Database.MySQL.Simple
import Database.MySQL.Simple.QueryResults (QueryResults, convertResults)
import Database.MySQL.Simple.Result (convert)
-- cabal install happstack
import Happstack.Server (dir, nullConf, simpleHTTP, toResponse, ok, ServerPart, Response, ServerPartT, look, body, decodeBody, defaultBodyPolicy)
import System.Locale (defaultTimeLocale)
import Text.Blaze (toValue)
import Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Printf (printf)


main:: IO()
main = do
  simpleHTTP nullConf $ allPages

allPages :: ServerPartT IO Response
allPages = do
  decodeBody (defaultBodyPolicy "/tmp" 0 10240 10240)
  msum [ mkTablePage
       , dropTablePage
       , insertFakeDataPage
       , dumpDataPage
       , newRunFormPage
       , handleNewRunPage
       ]

mkTablePage :: ServerPartT IO Response
mkTablePage = dir "admin" $ dir "mktable" $ do
  i <- liftIO mkTable
  ok (toResponse (executeSqlHtml "create table"i))

dropTablePage :: ServerPartT IO Response
dropTablePage = dir "admin" $ dir "droptable" $ do
  i <- liftIO dropTable
  ok (toResponse (executeSqlHtml "drop table" i))

insertFakeDataPage :: ServerPartT IO Response
insertFakeDataPage = dir "fakedata" $ do
  conn <- liftIO dbConnect
  n <- liftIO (execins conn)
  ok (toResponse (fakeDataHtml n))

dumpDataPage :: ServerPartT IO Response
dumpDataPage = dir "dump" $ do
  conn <- liftIO dbConnect
  runs <- liftIO $ query conn "SELECT miles, duration_sec, date, incline, comment FROM happstack.runs" ()
  ok (toResponse (dataTableHtml runs))

newRunFormPage :: ServerPartT IO Response
newRunFormPage = dir "newrun" $ do
  tz <- liftIO $ getCurrentTimeZone
  utcNow <- liftIO $ getCurrentTime
  localNow <- return $ utcToLocalTime tz utcNow
  ok $ toResponse $ newRunFormHtml localNow

handleNewRunPage :: ServerPartT IO Response
handleNewRunPage = dir "handlenewrun" $ do
  distance <- body $ look "distance"
  time <- body $ look "time"
  ok $ toResponse $ simpleMessageHtml (printf "%s in %s" distance time)

---------

data Run = Run { distance :: Float
               , duration :: Int
               , date :: Day
               , incline :: Float
               , comment :: String
               } deriving (Show)

instance QueryResults Run where
  convertResults [f_dist,f_dur,f_date,f_incl,f_comm] [v_dist,v_dur,v_date,v_incl,v_comm] =
    Run (convert f_dist v_dist) (convert f_dur v_dur) (convert f_date v_date) (convert f_incl v_incl) (convert f_comm v_comm)

---------

newRunFormHtml :: LocalTime -> H.Html
newRunFormHtml time =
  H.html $ do
    H.head $ do
      H.title "New Run"
    H.body $ do
      H.form ! A.method "post" ! A.action "/handlenewrun" $ do
        H.table $ do
          mconcat $ map (uncurry (newRunFormRow time))
                   [ ("distance", "text")
                   , ("time", "text")
                   , ("incline", "text")
                   , ("date", "date")
                   , ("comment", "text")
                   ]
        H.input ! A.type_ "submit"

newRunFormRow :: LocalTime -> String -> String -> H.Html
newRunFormRow time name formType =
  H.tr $ do
    H.td $
      H.label ! A.for (toValue name) $ H.toHtml name
    H.td $
      foldr (flip (!)) H.input (inputAttributes time name formType)

inputAttributes :: LocalTime -> String -> String -> [ H.Attribute ]
inputAttributes time name formType =
  let defaults = 
        [ A.type_ (toValue formType)
        , A.id (toValue name)
        , A.name (toValue name)
        ]
  in case formType of
    "date" -> (A.value (toValue (formatTimeForInput time))):defaults
    _ -> defaults

formatTimeForInput :: LocalTime -> String
formatTimeForInput time = formatTime defaultTimeLocale "%Y-%m-%d" time

dataTableHtml :: [ Run ] -> H.Html
dataTableHtml rs =
  H.html $ do
    H.head $ do
      H.title $ "Data"
    H.body $ do
      H.table $ do
        dataTableHeader
        mapM_ dataTableRow rs

dataTableHeader :: H.Html
dataTableHeader =
  H.thead $ H.tr $ do
    H.td "Date"
    H.td "Dist"
    H.td "Time"
    H.td "Incline"
    H.td "Pace"
    H.td "MpH"
    H.td "Note"

dataTableRow :: Run -> H.Html
dataTableRow r = H.tr $ do
  H.td $ H.toHtml $ show $ date r
  H.td $ H.toHtml $ show $ distance r
  H.td $ H.toHtml $ printDuration $ duration r
  H.td $ H.toHtml $ show $ incline r
  H.td $ H.toHtml $ printDuration $ pace r
  H.td $ H.toHtml $ show $ mph r
  H.td $ H.toHtml $ comment r

pace :: Run -> Int
pace r = round $ (fromIntegral (duration r)) / (distance r)

mph :: Run -> Float
mph r = 60 * 60 * (distance r) / (fromIntegral (duration r))

printDuration :: Int -> String
printDuration secs = printf "%d:%02d" (div secs 60) (mod secs 60)

fakeDataHtml :: Int64 -> H.Html
fakeDataHtml n = simpleMessageHtml (show n)

execins :: Connection -> IO Int64
execins conn = execute conn "INSERT INTO happstack.runs (date, miles, duration_sec, incline, comment) VALUES ('2014-12-9', 3.0, 1200, 1.0, 'First post!')" ()

--helloPage :: ServerPartT IO Response
--helloPage = do
--    message <- liftIoMyHead
--    helloPage2 message

--helloPage2 :: String -> ServerPartT IO Response
--helloPage2 msg = ok (toResponse (simpleMessageHtml msg))


liftIoMyHead :: ServerPartT IO String
liftIoMyHead = liftIO $ myHead getMessage

myHead :: IO [String] -> IO String
myHead xs = liftM head xs

dbConnect :: IO Connection
dbConnect = connect defaultConnectInfo
    { connectUser = "happstack"
    , connectPassword = "<PASSWORD>"
    , connectDatabase = "happstack"
    }

getMessage :: IO [String]
getMessage = do
  conn <- dbConnect
  results <- query conn "SELECT Message FROM foo" ()
  return $ map(\(Only r) -> r) results

--
-- Database Admin
--

dropTable :: IO Int64
dropTable = do
  conn <- dbConnect
  execute conn "DROP TABLE happstack.runs" ()

mkTable :: IO Int64
mkTable = do
  conn <- dbConnect
  execute conn "CREATE TABLE happstack.runs (\
               \ id INT NOT NULL AUTO_INCREMENT,\
               \ date DATE,\
               \ miles DECIMAL(5,2),\
               \ duration_sec INT,\
               \ incline DECIMAL(2,1),\
               \ comment VARCHAR(255),\
               \ PRIMARY KEY (id))" ()
--
-- HTML Templates
--
  
executeSqlHtml :: String -> Int64 -> H.Html
executeSqlHtml opname _ =
  H.html $ do
    H.head $ do
      H.title $ "executed database op"
    H.body $ H.toHtml opname

simpleMessageHtml :: String -> H.Html
simpleMessageHtml msg =
  H.html $ do
    H.head $ do
      H.title $ "Hello, world!"
    H.body $ do
      H.toHtml msg

<commit_msg>rearranged where extra Attrs are added, and added a pretty field name<commit_after>{-# LANGUAGE OverloadedStrings #-}

import Control.Monad (liftM, msum, forM_)
import Control.Monad.IO.Class (liftIO)
import Data.Int (Int64)
import Data.Monoid (mconcat)
import Data.Time.Calendar (Day)
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Format (formatTime)
import Data.Time.LocalTime (LocalTime, utcToLocalTime, getCurrentTimeZone, TimeZone)
-- sudo apt-get install libmysqlclient-dev
-- cabal install mysql-simple
import Database.MySQL.Simple
import Database.MySQL.Simple.QueryResults (QueryResults, convertResults)
import Database.MySQL.Simple.Result (convert)
-- cabal install happstack
import Happstack.Server (dir, nullConf, simpleHTTP, toResponse, ok, ServerPart, Response, ServerPartT, look, body, decodeBody, defaultBodyPolicy)
import System.Locale (defaultTimeLocale)
import Text.Blaze (toValue)
import Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Printf (printf)


main:: IO()
main = do
  simpleHTTP nullConf $ allPages

allPages :: ServerPartT IO Response
allPages = do
  decodeBody (defaultBodyPolicy "/tmp" 0 10240 10240)
  msum [ mkTablePage
       , dropTablePage
       , insertFakeDataPage
       , dumpDataPage
       , newRunFormPage
       , handleNewRunPage
       ]

mkTablePage :: ServerPartT IO Response
mkTablePage = dir "admin" $ dir "mktable" $ do
  i <- liftIO mkTable
  ok (toResponse (executeSqlHtml "create table"i))

dropTablePage :: ServerPartT IO Response
dropTablePage = dir "admin" $ dir "droptable" $ do
  i <- liftIO dropTable
  ok (toResponse (executeSqlHtml "drop table" i))

insertFakeDataPage :: ServerPartT IO Response
insertFakeDataPage = dir "fakedata" $ do
  conn <- liftIO dbConnect
  n <- liftIO (execins conn)
  ok (toResponse (fakeDataHtml n))

dumpDataPage :: ServerPartT IO Response
dumpDataPage = dir "dump" $ do
  conn <- liftIO dbConnect
  runs <- liftIO $ query conn "SELECT miles, duration_sec, date, incline, comment FROM happstack.runs" ()
  ok (toResponse (dataTableHtml runs))

newRunFormPage :: ServerPartT IO Response
newRunFormPage = dir "newrun" $ do
  tz <- liftIO $ getCurrentTimeZone
  utcNow <- liftIO $ getCurrentTime
  localNow <- return $ utcToLocalTime tz utcNow
  ok $ toResponse $ newRunFormHtml localNow

handleNewRunPage :: ServerPartT IO Response
handleNewRunPage = dir "handlenewrun" $ do
  distance <- body $ look "distance"
  time <- body $ look "time"
  ok $ toResponse $ simpleMessageHtml (printf "%s in %s" distance time)

---------

data Run = Run { distance :: Float
               , duration :: Int
               , date :: Day
               , incline :: Float
               , comment :: String
               } deriving (Show)

instance QueryResults Run where
  convertResults [f_dist,f_dur,f_date,f_incl,f_comm] [v_dist,v_dur,v_date,v_incl,v_comm] =
    Run (convert f_dist v_dist) (convert f_dur v_dur) (convert f_date v_date) (convert f_incl v_incl) (convert f_comm v_comm)

---------

newRunFormHtml :: LocalTime -> H.Html
newRunFormHtml time =
  H.html $ do
    H.head $ do
      H.title "New Run"
    H.body $ do
      H.form ! A.method "post" ! A.action "/handlenewrun" $ do
        H.table $ do
          mconcat $ map newRunFormRow
                   [ ("Distance", "distance", "text", [])
                   , ("Time", "time", "text", [])
                   , ("Incline", "incline", "text", [])
                   , ("Date", "date", "date", [
                         (A.value (toValue (formatTimeForInput time)))])
                   , ("Comment", "comment", "text", [
                         (A.size (toValue (75 :: Int)))])
                   ]
        H.input ! A.type_ "submit"

newRunFormRow :: (String, String, String, [H.Attribute]) -> H.Html
newRunFormRow (name, id, formType, extraAs) =
  let defaultAs = 
        [ A.type_ (toValue formType)
        , A.id (toValue id)
        , A.name (toValue id)
        ] in
  H.tr $ do
    H.td $
      H.label ! A.for (toValue id) $ H.toHtml name
    H.td $
      foldr (flip (!)) H.input (defaultAs ++ extraAs)


formatTimeForInput :: LocalTime -> String
formatTimeForInput time = formatTime defaultTimeLocale "%Y-%m-%d" time

dataTableHtml :: [ Run ] -> H.Html
dataTableHtml rs =
  H.html $ do
    H.head $ do
      H.title $ "Data"
    H.body $ do
      H.table $ do
        dataTableHeader
        mapM_ dataTableRow rs

dataTableHeader :: H.Html
dataTableHeader =
  H.thead $ H.tr $ do
    H.td "Date"
    H.td "Dist"
    H.td "Time"
    H.td "Incline"
    H.td "Pace"
    H.td "MpH"
    H.td "Note"

dataTableRow :: Run -> H.Html
dataTableRow r = H.tr $ do
  H.td $ H.toHtml $ show $ date r
  H.td $ H.toHtml $ show $ distance r
  H.td $ H.toHtml $ printDuration $ duration r
  H.td $ H.toHtml $ show $ incline r
  H.td $ H.toHtml $ printDuration $ pace r
  H.td $ H.toHtml $ show $ mph r
  H.td $ H.toHtml $ comment r

pace :: Run -> Int
pace r = round $ (fromIntegral (duration r)) / (distance r)

mph :: Run -> Float
mph r = 60 * 60 * (distance r) / (fromIntegral (duration r))

printDuration :: Int -> String
printDuration secs = printf "%d:%02d" (div secs 60) (mod secs 60)

fakeDataHtml :: Int64 -> H.Html
fakeDataHtml n = simpleMessageHtml (show n)

execins :: Connection -> IO Int64
execins conn = execute conn "INSERT INTO happstack.runs (date, miles, duration_sec, incline, comment) VALUES ('2014-12-9', 3.0, 1200, 1.0, 'First post!')" ()

--helloPage :: ServerPartT IO Response
--helloPage = do
--    message <- liftIoMyHead
--    helloPage2 message

--helloPage2 :: String -> ServerPartT IO Response
--helloPage2 msg = ok (toResponse (simpleMessageHtml msg))


liftIoMyHead :: ServerPartT IO String
liftIoMyHead = liftIO $ myHead getMessage

myHead :: IO [String] -> IO String
myHead xs = liftM head xs

dbConnect :: IO Connection
dbConnect = connect defaultConnectInfo
    { connectUser = "happstack"
    , connectPassword = "<PASSWORD>"
    , connectDatabase = "happstack"
    }

getMessage :: IO [String]
getMessage = do
  conn <- dbConnect
  results <- query conn "SELECT Message FROM foo" ()
  return $ map(\(Only r) -> r) results

--
-- Database Admin
--

dropTable :: IO Int64
dropTable = do
  conn <- dbConnect
  execute conn "DROP TABLE happstack.runs" ()

mkTable :: IO Int64
mkTable = do
  conn <- dbConnect
  execute conn "CREATE TABLE happstack.runs (\
               \ id INT NOT NULL AUTO_INCREMENT,\
               \ date DATE,\
               \ miles DECIMAL(5,2),\
               \ duration_sec INT,\
               \ incline DECIMAL(2,1),\
               \ comment VARCHAR(255),\
               \ PRIMARY KEY (id))" ()
--
-- HTML Templates
--
  
executeSqlHtml :: String -> Int64 -> H.Html
executeSqlHtml opname _ =
  H.html $ do
    H.head $ do
      H.title $ "executed database op"
    H.body $ H.toHtml opname

simpleMessageHtml :: String -> H.Html
simpleMessageHtml msg =
  H.html $ do
    H.head $ do
      H.title $ "Hello, world!"
    H.body $ do
      H.toHtml msg


{'fraction_non_alphanumeric': 0.11684531837864698, 'fraction_numerical': 0.008802441967771704, 'mean_word_length': 2.778969957081545, 'pattern_counts': {'":': 0, '<': 37, '<?xml version=': 0, '>': 44, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2515494', 'n_tokens_mistral': 4702, 'n_tokens_neox': 4531, 'n_words': 1370}