Haskell API client pagination - rest

I'm trying to build a Haskell client to consume a RESTful JSON API. I want to fetch a page, then take the "next_page" key from the response, and feed it into the query params of another api request. I want to continue doing this until I have paged through all the items. What is the cleanest way of doing this in Haskell? I'm using explicit recursion now, but I feel there must be a better way, maybe with the writer or state monad.
EDIT: Added my code. I'm aware I'm misusing fromJust.
data Post = Post {
title :: !Text,
domain :: !Text,
score :: Int,
url :: !Text
} deriving (Show)
instance FromJSON Post where
parseJSON (Object v) = do
objectData <- v .: "data"
title <- objectData .: "title"
domain <- objectData .: "domain"
score <- objectData .: "score"
url <- objectData .: "url"
return $ Post title domain score url
data GetPostsResult = GetPostsResult {
posts :: [Post],
after :: Maybe Text
} deriving (Show)
instance FromJSON GetPostsResult where
parseJSON (Object v) = do
rootData <- v .: "data"
posts <- rootData .: "children"
afterCode <- rootData .:? "after"
return $ GetPostsResult posts afterCode
fetchPage:: Text -> IO (Maybe ([Post],Maybe Text))
fetchPage afterCode = do
let url = "https://www.reddit.com/r/videos/top/.json?sort=top&t=day&after=" ++ unpack afterCode
b <- get url
let jsonBody = b ^. responseBody
let postResponse = decode jsonBody :: Maybe GetPostsResult
let pagePosts = posts <$> postResponse
let nextAfterCode = after $ fromJust postResponse
if isNothing pagePosts then return Nothing else return (Just (fromJust pagePosts,nextAfterCode))
getPosts :: Text -> [Post] -> IO [Post]
getPosts x y = do
p <- liftIO $ fetchPage x
let posts = fst (fromJust p)
let afterParam = snd (fromJust p)
case afterParam of
Nothing -> return []
Just aff -> getPosts aff (posts ++ y)
main = do
a <- getPosts "" []
print a

Your approach is certainly appealing due to it's simplicity, however it has the disadvantage, that the list of Posts will only be available after the whole pagination chain has ended.
I would suggest to use a streaming library like Pipe, Conduit and friends. The advantage is that you can stream the results and also limit the number of posts to retrieve, by using functions provided by the respective streaming library. Here is an example with Pipe, I added the necessary imports and added postsP:
{-# LANGUAGE OverloadedStrings #-}
import Data.Aeson
import Data.Text (Text)
import qualified Data.Text as T
import Network.Wreq
import Data.Maybe
import Control.Lens
import Control.Monad.IO.Class
import qualified Pipes as P
import Data.Foldable (for_)
data Post = Post {
title :: !Text,
domain :: !Text,
score :: Int,
url :: !Text
} deriving (Show)
instance FromJSON Post where
parseJSON (Object v) = do
objectData <- v .: "data"
title <- objectData .: "title"
domain <- objectData .: "domain"
score <- objectData .: "score"
url <- objectData .: "url"
return $ Post title domain score url
data GetPostsResult = GetPostsResult {
posts :: [Post],
after :: Maybe Text
} deriving (Show)
instance FromJSON GetPostsResult where
parseJSON (Object v) = do
rootData <- v .: "data"
posts <- rootData .: "children"
afterCode <- rootData .:? "after"
return $ GetPostsResult posts afterCode
fetchPage:: Text -> IO (Maybe ([Post],Maybe Text))
fetchPage afterCode = do
let url = "https://www.reddit.com/r/videos/top/.json?sort=top&t=day&after=" ++ T.unpack afterCode
b <- get url
let jsonBody = b ^. responseBody
let postResponse = decode jsonBody :: Maybe GetPostsResult
let pagePosts = posts <$> postResponse
let nextAfterCode = after $ fromJust postResponse
if isNothing pagePosts then return Nothing else return (Just (fromJust pagePosts,nextAfterCode))
getPosts :: Text -> [Post] -> IO [Post]
getPosts x y = do
p <- liftIO $ fetchPage x
let posts = fst (fromJust p)
let afterParam = snd (fromJust p)
case afterParam of
Nothing -> return []
Just aff -> getPosts aff (posts ++ y)
postsP :: Text -> P.Producer Post IO ()
postsP x = do
p <- liftIO (fetchPage x)
for_ p $ \(posts,afterParam) -> do
P.each posts
for_ afterParam postsP
main = P.runEffect $ P.for (postsP "") (liftIO . print)

I would suggest you need a continuation monad. Within the continuation you can have the logic to assemble a page, yield it to the caller of the continuation, and then repeat. When you call your "get_pages" function you will get back the first page and a new function that takes your new parameters.
It sounds like you need this answer, which shows how to create such a monad. Make it a monad transformer if you need any other monadic state inside your function.

Related

Purescript Halogen manually trigger input validation outside of a form

I have input fields which I have marked with a required attribute, but can't figure out a way to trigger a validation check (I am not working inside of a form, so using a default submit button action won't work for me).
A quick pursuit search shows many validity functions for core html element types, but I'm not sure how to apply these to Halogen.
Is there some way to trigger a DOM effect to check all required inputs on the page and get a result back?
Here is an example component showing what I'm trying to achieve
import Prelude
import Data.Maybe (Maybe(..))
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
data Message = Void
type State =
{ textValue :: String
, verified :: Boolean
}
data Query a = ContinueClicked a | InputEntered String a
inputHtml :: State -> H.ComponentHTML Query
inputHtml state =
HH.div [ HP.class_ $ H.ClassName "input-div" ]
[ HH.label_ [ HH.text "This is a required field" ]
, HH.input [ HP.type_ HP.InputText
, HE.onValueInput $ HE.input InputEntered
, HP.value state.textValue
, HP.required true
]
, HH.button [ HE.onClick $ HE.input_ ContinueClicked ]
[ HH.text "Continue"]
]
verifiedHtml :: H.ComponentHTML Query
verifiedHtml =
HH.div_ [ HH.h3_ [ HH.text "Verified!" ] ]
render :: State -> H.ComponentHTML Query
render state = if state.verified then verifiedHtml else inputHtml state
eval :: forall m. Query ~> H.ComponentDSL State Query Message m
eval = case _ of
InputEntered v next -> do
H.modify $ (_ { textValue = v })
pure next
ContinueClicked next -> do
let inputValid = false -- somehow use the required prop to determine if valid
when inputValid $ H.modify $ (_ { verified = true })
pure next
initialState :: State
initialState =
{ textValue : ""
, verified : false
}
component :: forall m. H.Component HH.HTML Query Unit Message m
component =
H.component
{ initialState: const initialState
, render
, eval
, receiver: const Nothing
}
I don't think relying on HTML form validation is the most effective way of checking inputs within a Halogen application. But I'll assume you have your reasons and present an answer anyway.
First things first, if we want to deal with DOM elements we need a way to retrieve them. Here's a purescript version of document.getElementById
getElementById
:: forall a eff
. (Foreign -> F a)
-> String
-> Eff (dom :: DOM | eff) (Maybe a)
getElementById reader elementId =
DOM.window
>>= DOM.document
<#> DOM.htmlDocumentToNonElementParentNode
>>= DOM.getElementById (wrap elementId)
<#> (_ >>= runReader reader)
runReader :: forall a b. (Foreign -> F b) -> a -> Maybe b
runReader r =
hush <<< runExcept <<< r <<< toForeign
(Don't worry about the new imports for now, there's a complete module at the end)
This getElementById function takes a read* function (probably from DOM.HTML.Types) to determine the type of element you get back, and an element id as a string.
In order to use this, we need to add an extra property to your HH.input:
HH.input [ HP.type_ HP.InputText
, HE.onValueInput $ HE.input InputEntered
, HP.value state.textValue
, HP.required true
, HP.id_ "myInput" <-- edit
]
Aside: a sum type with a Show instance would be safer than hard-coding stringy ids everywhere. I'll leave that one to you.
Cool. Now we need to call this from the ContinueClicked branch of your eval function:
ContinueClicked next ->
do maybeInput <- H.liftEff $
getElementById DOM.readHTMLInputElement "myInput"
...
This gives us a Maybe HTMLInputElement to play with. And that HTMLInputElement should have a validity property of type ValidityState, which has the information we're after.
DOM.HTML.HTMLInputElement has a validity function that will give us access to that property. Then we'll need to do some foreign value manipulation to try and get the data out that we want. For simplicity, let's just try and pull out the valid field:
isValid :: DOM.ValidityState -> Maybe Boolean
isValid =
runReader (readProp "valid" >=> readBoolean)
And with that little helper, we can finish the ContinueClicked branch:
ContinueClicked next ->
do maybeInput <- H.liftEff $
getElementById DOM.readHTMLInputElement "myInput"
pure next <*
case maybeInput of
Just input ->
do validityState <- H.liftEff $ DOM.validity input
when (fromMaybe false $ isValid validityState) $
H.modify (_ { verified = true })
Nothing ->
H.liftEff $ log "myInput not found"
And then putting it all together we have...
module Main where
import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import Data.Either (hush)
import Data.Foreign (Foreign, F, toForeign, readBoolean)
import Data.Foreign.Index (readProp)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (wrap)
import DOM (DOM)
import DOM.HTML (window) as DOM
import DOM.HTML.HTMLInputElement (validity) as DOM
import DOM.HTML.Types
(ValidityState, htmlDocumentToNonElementParentNode, readHTMLInputElement) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.NonElementParentNode (getElementById) as DOM
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver (runUI)
main :: Eff (HA.HalogenEffects (console :: CONSOLE)) Unit
main = HA.runHalogenAff do
body <- HA.awaitBody
runUI component unit body
type Message
= Void
type Input
= Unit
type State
= { textValue :: String
, verified :: Boolean
}
data Query a
= ContinueClicked a
| InputEntered String a
component
:: forall eff
. H.Component HH.HTML Query Unit Message (Aff (console :: CONSOLE, dom :: DOM | eff))
component =
H.component
{ initialState: const initialState
, render
, eval
, receiver: const Nothing
}
initialState :: State
initialState =
{ textValue : ""
, verified : false
}
render :: State -> H.ComponentHTML Query
render state =
if state.verified then verifiedHtml else inputHtml
where
verifiedHtml =
HH.div_ [ HH.h3_ [ HH.text "Verified!" ] ]
inputHtml =
HH.div
[ HP.class_ $ H.ClassName "input-div" ]
[ HH.label_ [ HH.text "This is a required field" ]
, HH.input
[ HP.type_ HP.InputText
, HE.onValueInput $ HE.input InputEntered
, HP.value state.textValue
, HP.id_ "myInput"
, HP.required true
]
, HH.button
[ HE.onClick $ HE.input_ ContinueClicked ]
[ HH.text "Continue" ]
]
eval
:: forall eff
. Query
~> H.ComponentDSL State Query Message (Aff (console :: CONSOLE, dom :: DOM | eff))
eval = case _ of
InputEntered v next ->
do H.modify (_{ textValue = v })
pure next
ContinueClicked next ->
do maybeInput <- H.liftEff $
getElementById DOM.readHTMLInputElement "myInput"
pure next <*
case maybeInput of
Just input ->
do validityState <- H.liftEff $ DOM.validity input
when (fromMaybe false $ isValid validityState) $
H.modify (_ { verified = true })
Nothing ->
H.liftEff $ log "myInput not found"
getElementById
:: forall a eff
. (Foreign -> F a)
-> String
-> Eff (dom :: DOM | eff) (Maybe a)
getElementById reader elementId =
DOM.window
>>= DOM.document
<#> DOM.htmlDocumentToNonElementParentNode
>>= DOM.getElementById (wrap elementId)
<#> (_ >>= runReader reader)
isValid :: DOM.ValidityState -> Maybe Boolean
isValid =
runReader (readProp "valid" >=> readBoolean)
runReader :: forall a b. (Foreign -> F b) -> a -> Maybe b
runReader r =
hush <<< runExcept <<< r <<< toForeign

Purescript types for buildQueryString function

I am new to Purescript and I am trying to write a function that
can take any record value and iterate over the fields and values and build
a querystring.
I am thinking something like:
buildQueryString :: forall a. PropertyTraversible r => r -> String
which I want to use like this:
buildQueryString {name: "joe", age: 10} -- returns: "name=joe&age=10"
Is there a way to write something like that in Purescript with existing idioms or do I have to create my own custom Type Class for this?
I'm sure that it can be shorter, but here is my implementation based on purescript-generic-rep (inspired by genericShow). This solution uses typeclasses - it seems to be standard approach with generic-rep:
module Main where
import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Foldable (intercalate)
import Data.Generic.Rep (class Generic, Constructor(..), Field(..), Product(..), Rec(..), from)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
class EncodeValue a where
encodeValue ∷ a → String
instance encodeValueString ∷ EncodeValue String where
encodeValue = id
instance encodeValueInt ∷ EncodeValue Int where
encodeValue = show
class EncodeFields a where
encodeFields :: a -> Array String
instance encodeFieldsProduct
∷ (EncodeFields a, EncodeFields b)
⇒ EncodeFields (Product a b) where
encodeFields (Product a b) = encodeFields a <> encodeFields b
instance encodeFieldsField
∷ (EncodeValue a, IsSymbol name)
⇒ EncodeFields (Field name a) where
encodeFields (Field a) =
[reflectSymbol (SProxy :: SProxy name) <> "=" <> encodeValue a]
buildQueryString
∷ ∀ a l n.
Generic n (Constructor l (Rec a))
⇒ (EncodeFields a)
⇒ n
→ String
buildQueryString n =
build <<< from $ n
where
build (Constructor (Rec fields)) = intercalate "&" <<< encodeFields $ fields
newtype Person =
Person
{ name ∷ String
, age ∷ Int
}
derive instance genericPerson ∷ Generic Person _
joe ∷ Person
joe = Person { name: "joe", age: 10 }
main :: forall e. Eff (console :: CONSOLE | e) Unit
main = do
log <<< buildQueryString $ joe
buildQueryString expects value of type with single constructor which contains a record (possibly just newtype) because it is impossible to derive a Generic instance for "unwrapped" Record type.
If you want to handle also Array values etc. then encodeValue should probably return values of type Array String.
This is possible with purescript-generics but it only works on nominal types, not on any record. But it saves you boilerplate, since you can just derive the instance for Generic, so it would work with any data or newtype without further modification.
Downside is, you have to make some assumptions about the type: like it only contains one record and the record does not contain arrays or other records.
Here is a hacky demonstration how it would work:
data Person = Person
{ name :: String
, age :: Int
}
derive instance genericPerson :: Generic Person
joe = Person { name: "joe", age: 10 }
build :: GenericSpine -> String
build (SRecord arr) = intercalate "&" (map (\x -> x.recLabel <> "=" <> build (x.recValue unit)) arr)
build (SProd _ arr) = fromMaybe "TODO" $ map (\f -> build (f unit)) (head arr)
build (SString s) = s
build (SInt i) = show i
build _ = "TODO"
test = build (toSpine joe)
purescript-generics-rep is newer, so possibly there is a better solution, maybe even on any record. I have not tried that (yet).

How to handle effects with Pux?

I'm just a beginner to the whole world of Purescript and Pux, so I'm a little confused as to where we handle effects.
Currently I'm modelling the effects in my type:
type State = { countries ∷ Maybe (Eff (random :: RANDOM) Countries) }
And then using that in my foldp function:
foldp (Request) state = { state, effects: [countries] }
Where countries is defined as:
countries = do
response <- attempt $ get "/countries.json"
let countries = either (Left <<< show) decode response
pure $ Just $ Receive $ case shuffle <$> countries of
Left _ → Nothing
Right xs → Just xs
However at some point I need to unwrap the RANDOM effect from the type to be able to return it from my view: State → HTML Event.
You simply don't do any side effects in the view. Lift the random effect in your foldp:
data Countries
data Event = Request | Received (Maybe Countries) | FetchError String
type State = {countries :: Maybe Countries, error :: String}
type AppFx fx = (random :: RANDOM | fx)
foldp :: ∀ fx. FoldP State Event (AppFx fx)
foldp (FetchError msg) state = noEffects state{error = msg}
foldp (Received countries) state = noEffects state{countries = countries}
foldp Request state = {state, effects: pure countriesRequest}
where
countriesRequest = Just <$> do
response <- attempt $ getCountries
case response of
Left errorMsg -> pure $ FetchError $ show errorMsg
Right countries -> case shuffle countries of
Left _ -> pure $ Received Nothing
Right shuffleEff -> do
shuffledCountries <- liftEff shuffleEff
pure $ Received $ Just shuffledCountries
shuffle :: ∀ fx. Countries -> Either String (Eff (random :: RANDOM | fx) Countries)
shuffle = unsafeCrashWith "TODO"
getCountries :: ∀ fx. Aff fx Countries
getCountries = unsafeCrashWith "TODO"

Purescript Reuse Argonaut JSON Decoding for Affjax Respondeable

I'm trying to fetch some JSON data from a Haskell server, but I'm having trouble with the Respondeable instance, as well as just Affjax in general. I've defined EncodeJson + DecodeJson with Data.Argonaut.Generic.Aeson (GA), but I can't figure out how to fit that in with the Respondeable instance and it's fromResponse function.
It gives me the error "Could not match type Foreign with type Json" but is it possible to reuse my decodeJson instance without having to create anything else by hand? Maybe by creating an IsForeign instance, but using GA.decodeJson in that? I'm just not sure how to go about doing it. I've seen how it's done in https://github.com/purescript/purescript-foreign/blob/master/examples/Complex.purs by hand, but I have complex types that need to match up with my Haskell JSON output, and it's going to be a huge pain to do it manually.
I'm using purescript 10.7, Affjax 3.02, and argonaut 2.0.0, and argonaut-generic-codecs 5.1.0. Thanks!
testAffjax :: forall eff. Aff (ajax :: AJAX | eff) (Answer)
testAffjax = launchAff do
res <- affjax $ defaultRequest { url = "/", method = Left GET }
pure res.response
data Answer = Answer {
_answer :: String
, _isCorrect :: Boolean
, _hint :: String
}
{- PROBLEM -}
instance respondableAnswer :: Respondable Answer where
responseType = Tuple Nothing JSONResponse
fromResponse = GA.decodeJson {- Error here -}
derive instance genericAnswer :: Generic Answer
instance showAnswer :: Show Answer where
show = gShow
instance encodeAnswer :: EncodeJson Answer where
encodeJson = GA.encodeJson
instance decodeAnswer :: DecodeJson Answer where
decodeJson = GA.decodeJson
What you're looking for is a function that adapts a JSON decoder:
decodeJson :: forall a. Json -> Either String a
To return using F rather than Either. F is a synonym defined in Data.Foreign for Except MultipleErrors a. To do that we need to:
Translate our String error into a MultipleErrors
Convert from Either to Except
MultipleErrors is another synonym defined in Data.Foreign, this time for NonEmptyList ForeignError. Looking at ForeignError there's a constructor also called ForeignError that lets us provide some string message. That leaves us with the need to create a NonEmptyList, which is pretty easy:
remapError = pure <<< ForeignError
NonEmptyList is Applicative, so we can create a one-element list with pure.
To go from Either to Except is also straightforward. Again looking at the definitions in Pursuit we can see:
newtype ExceptT m e a = ExceptT (m (Either e a))
type Except = ExceptT Identity
So ExceptT is just a fancy Either already, giving us:
eitherToExcept = ExceptT <<< pure
The pure here is to lift Either e a into m (Either e a), which for Except m ~ Identity.
So now we can take this stuff, and make a general "decode JSON for Affjax responses" function:
decodeJsonResponse :: forall a. DecodeJson a => Json -> F a
decodeJsonResponse =
ExceptT <<< pure <<< lmap (pure <<< ForeignError) <<< decodeJson
The only other thing that happened in here is we used lmap to map over the left part of the Either, to do the error-message-type-conversion bit.
We can now use Kleisli composition ((<=<)) to chain this decodeJsonResponse together with the original fromResponse that will do the initial ResponseContent -> F Json:
instance respondableAnswer :: Respondable Answer where
responseType = Tuple (Just applicationJSON) JSONResponse
fromResponse = decodeJsonResponse <=< fromResponse
Here's the full example using your Answer type:
module Main where
import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Except (ExceptT(..))
import Data.Argonaut (class DecodeJson, class EncodeJson, Json, decodeJson)
import Data.Argonaut.Generic.Argonaut as GA
import Data.Bifunctor (lmap)
import Data.Foreign (F, ForeignError(..))
import Data.Generic (class Generic, gShow)
import Data.Maybe (Maybe(..))
import Data.MediaType.Common as MediaType
import Data.Tuple (Tuple(..))
import Network.HTTP.Affjax as AX
import Network.HTTP.Affjax.Response as AXR
testAffjax :: forall eff. Aff (ajax :: AX.AJAX | eff) Answer
testAffjax = _.response <$> AX.get "/"
newtype Answer = Answer
{ _answer :: String
, _isCorrect :: Boolean
, _hint :: String
}
derive instance genericAnswer :: Generic Answer
instance showAnswer :: Show Answer where
show = gShow
instance encodeAnswer :: EncodeJson Answer where
encodeJson = GA.encodeJson
instance decodeAnswer :: DecodeJson Answer where
decodeJson = GA.decodeJson
instance respondableAnswer :: AXR.Respondable Answer where
responseType = Tuple (Just MediaType.applicationJSON) AXR.JSONResponse
fromResponse = decodeJsonResponse <=< AXR.fromResponse
decodeJsonResponse :: forall a. DecodeJson a => Json -> F a
decodeJsonResponse =
ExceptT <<< pure <<< lmap (pure <<< ForeignError) <<< decodeJson

Program architecture using the monad reader in Scala

I'm trying to wrap my head around dependency injection in Scala using monad readers. I started learning Scala recently, so the code I give here, does not compile, but I hope my problem becomes clear. To start, lets assume our application allows a user to changes it password. First, I create a simple case class User and add a changePassword method on the companion object:
case class User (id:Int, username:String, password:String)
object User {
def changePassword (oldPassword:String, newPassword:String, user:User) = {
if (!user.password.equals(oldPassword)) {
-\/("Old password incorrect")
} else {
\/-(user.copy(password = newPassword))
}
}
}
Note that the changePassword method is still a bit to specific in its return type. In Haskell I would write:
data User = User {
id :: Int
, username :: String
, password :: String
} deriving (Show)
changePassword :: (MonadError String m) => String -> String -> User -> m User
changePassword old new user =
if password user == old
then return $ user { password = new }
else throwError "Old password incorrect"
This would allow the changePassword function to be used in any monad transformer stack which contains the Error monad.
Now, to create the application we need two more additional components. One component is a repository which knows how to retrieve and store User objects. Multiple implementations may exists. For example we may have a database repository in production and a in memory repository for testing purposes.
trait UserRepository {
def getById(id:Int):M[User]
def save (user:User):M[Unit]
}
object DatabaseUserRepository extends UserRepository {
def getById(id:Int):MonadReader[Connection,User]
def save (user:User):MonadReader[Connection,Unit]
}
object InMemoryUserRepository extends UserRepository {
def getById(id:Int):MonadState[UserMap,User]
def save (user:User):MonadState[UserMap,Unit]
}
Both implementations are monadic, but the monadic behavior they need may differ. I.e. the database repository depends on a connection which its may access using the reader monad while the in memory repository depends on the state monad.
The other component is a service component which acts as entry point to our logic from the UI.
object UserService {
def doChangePassword (id:Int, oldPassword:String, newPassword:String):MonadReader[UserRepository, Unit]
}
This component uses the user repository to retrieve the user by the given id and then calls the changePassword function and saves the updated user object back using the repository.
I hope this illustrates what I try to achieve. However, I'm still a bit puzzled how to connect the different parts together...
To answer my own question, at least partially. I searched google for this topic and found out about the concept of a free monad:
http://www.haskellforall.com/2012/06/you-could-have-invented-free-monads.html
After reading this, I came up with:
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
module Main where
import Control.Monad.Free
import Control.Monad.Error
import Control.Monad.Identity
import Control.Monad.State hiding (get)
import qualified Control.Monad.State as MS
import Data.IntMap
import Prelude hiding (lookup)
data User = User {
ident :: Int
, username :: String
, password :: String
} deriving (Show, Eq, Ord)
changePassword' :: (MonadError String m) => String -> String -> User -> m User
changePassword' old new user =
if password user == old
then return $ user { password = new }
else throwError "Old password incorrect"
type UserMap = IntMap User
data Interaction next = Save User next
| Get Int (User -> next)
| ChangePassword String String User (User -> next)
instance Functor Interaction where
fmap f (Save user next) = Save user (f next)
fmap f (Get id g) = Get id (f . g)
fmap f (ChangePassword old new user g) = ChangePassword old new user (f . g)
type Program = Free Interaction
save :: User -> Program ()
save user = liftF (Save user ())
get :: Int -> Program User
get ident = liftF (Get ident id)
changePassword :: String -> String -> User -> Program User
changePassword old new user = liftF (ChangePassword old new user id)
doChangePassword :: String -> String -> Int -> Program ()
doChangePassword old new ident = get ident
>>= changePassword old new
>>= save
newtype ST a = ST { run :: StateT UserMap (ErrorT String Identity) a } deriving (Monad, MonadState UserMap, MonadError String)
runST :: ST a -> UserMap -> UserMap
runST (ST x) s = case runIdentity (runErrorT (execStateT x s)) of
Left message -> error message
Right state -> state
interpreter :: Program r -> ST r
interpreter (Pure r) = return r
interpreter (Free (Save user next)) = do
modify (\map -> insert (ident user) user map)
interpreter next
interpreter (Free (Get id g)) = do
userMap <- MS.get
case lookup id userMap of
Nothing -> throwError "Unknown identifier"
Just user -> interpreter (g user)
interpreter (Free (ChangePassword old new user g)) = do
user' <- changePassword' old new user
interpreter (g user')
main = (putStrLn . show) $ runST (interpreter p) (fromList [(1, User 1 "username" "secret")])
where
p = doChangePassword "secret" "new" 1
Here we define a small language consisting of three operations: Get, Save and ChangePassword. Then we define our function in terms of these 3 operations:
doChangePassword :: String -> String -> Int -> Program ()
doChangePassword old new ident = get ident
>>= changePassword old new
>>= save
The result of this function is simply a structure describing a small program which we need to execute. For this, we write a small interpreter. Changing from a database repository to an in memory repository is achieved by providing a different interpreter.
Composing multiple languages is possible by defining coproducts as described in data types a la carte (http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.101.4131&rep=rep1&type=pdf). But until now, I didn't have time yet to try this out.