Add remaining haskell book exercises
This commit is contained in:
61
Haskell-book/26/Exercises/app/Main.hs
Normal file
61
Haskell-book/26/Exercises/app/Main.hs
Normal file
@@ -0,0 +1,61 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.IORef
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text.Lazy (Text)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import System.Environment (getArgs)
|
||||
import Web.Scotty.Trans ( ScottyT(..)
|
||||
, ActionT(..)
|
||||
, scottyT
|
||||
, get
|
||||
, html
|
||||
, param )
|
||||
|
||||
data Config =
|
||||
Config {
|
||||
-- that's one, one click!
|
||||
-- two...two clicks!
|
||||
-- Three BEAUTIFUL clicks! ah ah ahhhh
|
||||
counts :: IORef (M.Map Text Integer)
|
||||
, prefix :: Text
|
||||
}
|
||||
|
||||
type Scotty = ScottyT Text (ReaderT Config IO)
|
||||
|
||||
bumpBoomp :: Text
|
||||
-> M.Map Text Integer
|
||||
-> (M.Map Text Integer, Integer)
|
||||
bumpBoomp k m =
|
||||
let (maybeCount, newMap) = M.insertLookupWithKey (\_ _ oldCount -> oldCount + 1) k 1 m
|
||||
in case maybeCount of
|
||||
Nothing -> (newMap, 1)
|
||||
Just oldCount -> (newMap, oldCount + 1)
|
||||
|
||||
app :: Scotty ()
|
||||
app =
|
||||
get "/:key" $ do
|
||||
unprefixed <- param "key"
|
||||
prefix <- lift $ asks prefix
|
||||
let key' = mappend prefix unprefixed
|
||||
counts <- lift $ asks counts
|
||||
(newMap, newInteger) <- liftIO $ bumpBoomp key' <$> readIORef counts
|
||||
liftIO $ writeIORef counts newMap
|
||||
html $ mconcat [ "<h1>Success! Count was: "
|
||||
, TL.pack $ show (newInteger :: Integer)
|
||||
, "</h1>"
|
||||
]
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
[prefixArg] <- getArgs
|
||||
counter <- newIORef M.empty
|
||||
let config = Config {counts = counter, prefix = TL.pack prefixArg}
|
||||
runR = flip runReaderT config
|
||||
scottyT 3000 runR app
|
||||
Reference in New Issue
Block a user