Snap, IO and acid-state - haskell

Trying to use acid-state in Snap, and I hit a roadblock.
Here is what I got so far.
First my acid-state related objects (it's a dummy book with a isbn number):
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
module Models where
import Prelude hiding ((.), id)
import Control.Category ((.))
import Control.Monad.Reader (asks)
import Data.ByteString (ByteString)
import Data.SafeCopy (base, deriveSafeCopy)
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Data.Acid (Update, Query, makeAcidic)
import Control.Monad.Reader (ask)
import Control.Applicative ((<$>))
import Data.Data (Data)
data Book = Book { isbn :: String }
deriving (Eq, Ord, Read, Data, Show, Typeable)
$(deriveSafeCopy 0 'base ''Book)
-- Retrieve the book's isbn
queryIsbn :: Query Book String
queryIsbn = isbn <$> ask
$(makeAcidic ''Book ['queryIsbn])
And then my actual attempt at integrating it with Snap. As you can see, I am having trouble defining __ doQuery__ function, that should return a string isbn:
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module Application where
import Control.Monad.Trans.Class (lift)
import Data.Text.Encoding (decodeUtf8)
import Text.XmlHtml (Node(TextNode),Node (Element),
getAttribute, setAttribute, nodeText)
import Data.ByteString (ByteString)
import Data.Maybe
import Snap.Core
import Snap.Snaplet
import Snap.Snaplet.Heist (Heist, HasHeist(heistLens), heistInit,
addSplices, liftHeist, render)
import Snap.Util.FileServe
import Text.Templating.Heist (HeistT, Template, getParamNode)
import Data.Lens.Template
import Models
import Data.Acid.Advanced (query')
import Data.Acid (AcidState, openLocalState, closeAcidState, IsAcidic, query)
import Data.Text (pack)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Snap (snapletValue)
import Data.Lens.Common (getL, (^$), (^.), Lens)
import Control.Monad.Reader (ask, asks)
import Control.Applicative ((<$>))
import Data.Typeable (typeOf)
import Prelude hiding ((.), id)
import Control.Category ((.), id)
------------------------------------------------------------------------------
type AppHandler = Handler App App
--------------
-- Acid
---------------
-- Used for holding data for the snapplet
data Acid st = Acid { _state :: AcidState st }
-- Initializer function for the snapplet
seedBook = Book "9213-23123-2311"
acidInit :: SnapletInit b (Acid Book)
acidInit = makeSnaplet "storage" "Snaplet providing storage functionality" Nothing initializer
--The 'm' is the type variable of the MonadSnaplet type class. 'b' is the base state, and 'v' is the state of the current "view" snaplet (or simply, current state).
initializer :: Initializer b v (Acid Book)
initializer = do
st <- liftIO (openLocalState seedBook)
--onUnload (closeAcidState st)
return $ Acid st
-----------------------
-- Snap Global State
--------------------
data App = App
{ _heist :: Snaplet (Heist App),
_acid :: Snaplet (Acid Book)
}
makeLens ''App
----------------------------------------------------------------------------------
instance HasHeist App where
heistLens = subSnaplet heist
-----------------------------------------------
-- | Initialize app
-----------------------------------------------
appInit :: SnapletInit App App
appInit = makeSnaplet "app" "Website" Nothing $ do
h <- nestSnaplet "" heist $ heistInit "templates"
a <- nestSnaplet "isbn" acid (acidInit)
addRoutes routes --see below
addSplices [ ("menuEntry", liftHeist menuEntrySplice) ]
return $ App h a
------------------------------------------------
-- | The application's routes.
------------------------------------------------
routes :: [(ByteString, Handler App App ())]
routes = [ ("/books", handleBooks)
, ("/contact", render "contact")
, ("/isbn", liftIO doQuery >>= writeBS )
, ("", serveDirectory "static")
]
-- Is this Function signature possible? Or must it run inside Snap or other monad?
doQuery :: IO ByteString
doQuery = do -- ???????????
--somehow retrieve acid store from snaplet
--run queryIsbn on it
--return isbn string
return "BLAH"
handleBooks :: Handler App App ()
handleBooks = render "books"
Any help on what I am missing would be greatly appreciated. If something is not clear, please let me know and I'll update the question.

MathematicalOrchid is correct, the simplest answer to your problem is to use liftIO on the openLocalState call.
But from a broader view, what you're doing here has already been done for you by the snaplet-acid-state package, so I would recommend that you just use that. The repository also includes an example application demonstrating how to use it.

I have no idea about the packages you're using, but it looks like the problem is simply that openLocalState is an IO action, but your type signature requires it to be an Initializer action.
Fixing it might be as simple as stuffing a call to liftIO in there. I'm not really sure though... I don't know which module each of these types comes from.

Related

Scotty and persistence - type error when using insert function

I've got the following application:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Main where
-- Scotty
import qualified Web.Scotty as S
import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.Static
import qualified Data.Text.Lazy as L
-- HTML rendering
import Text.Blaze.Html.Renderer.Text (renderHtml)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Control.Monad.IO.Class
-- Database
import Database.Persist
import Database.Persist.Sqlite
import Database.Persist.TH
import Control.Monad.Trans.Resource (runResourceT, ResourceT)
import Control.Monad.Logger
-- URL generation
import System.Random
import Control.Monad (replicateM)
-- JSON
import Data.Map (fromList)
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Link
shortUrl L.Text
URLKey shortUrl
Primary shortUrl
longUrl L.Text
counter Int
deriving Show
|]
getURL :: L.Text -> IO (Maybe (Entity Link))
getURL shortId = runSqlite "links.db" $ do
maybeOriginal <- getBy $ URLKey shortId
pure maybeOriginal
-- I don't know what type to give this, that's probably the problem
addURL short long = runSqlite "links.db" $ do
insert $ Link short long
main :: IO ()
main = do
-- Connect to db and run migration
runSqlite "links.db" $ do runMigration migrateAll
S.scotty 3000 $ do
...
S.post "/shorten" $ do
-- Get URL
url <- S.param "url" :: S.ActionM L.Text
-- Generate a random short URL
randStr <- liftIO $ getRandStr 5
-- Add the urls to the database
liftIO $ addURL (L.pack randStr) url
-- Send JSON response with ID
S.json $ fromList [("id" :: String, randStr)]
I get the following error:
shortener> build (lib + exe)
Preprocessing library for shortener-0.1.0.0..
Building library for shortener-0.1.0.0..
Preprocessing executable 'shortener-exe' for shortener-0.1.0.0..
Building executable 'shortener-exe' for shortener-0.1.0.0..
[2 of 2] Compiling Main
/home/henry/haskell/shortener/app/Main.hs:86:5: error:
• Couldn't match type ‘PersistEntityBackend (Int -> Link)’
with ‘SqlBackend’
arising from a use of ‘insert’
• In the first argument of ‘($)’, namely ‘insert’
In a stmt of a 'do' block: insert $ Link short long
In the second argument of ‘($)’, namely
‘do insert $ Link short long’
|
86 | insert $ Link short long
| ^^^^^^
-- While building package shortener-0.1.0.0 (scroll up to its section to see the error) using:
/home/henry/.stack/setup-exe-cache/x86_64-linux-tinfo6/Cabal-simple_mPHDZzAJ_3.4.1.0_ghc-9.0.2 --builddir=.stack-work/dist/x86_64-linux-tinfo6/Cabal-3.4.1.0 build lib:shortener exe:shortener-exe --ghc-options " -fdiagnostics-color=always"
Process exited with code: ExitFailure 1
I'm not sure how to resolve this type error and I haven't been able to find anything of use online. There was this answer with a similar problem, but the given type signature and several variations of it did not work.
It turns out I forgot a field when inserting. I had
insert $ Link short long
I needed
insert $ Link short long 0
for the counter field of Link.
Unfortunately the error didn't make that at all clear.

Typed version of Plutus Pionneers homework01 (week02) [closed]

Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 1 year ago.
Improve this question
I've tried to code a typed version of the first homework exercise. It compiles but fails to render in the playground...
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
import Control.Monad hiding (fmap)
import GHC.Generics (Generic)
import Data.Aeson (FromJSON, ToJSON)
import Data.Map as Map
import Data.Text (Text)
import Data.Void (Void)
import Plutus.Contract hiding (when)
import PlutusTx (Data (..))
import qualified PlutusTx
import PlutusTx.Prelude hiding (Semigroup(..), unless)
import Ledger hiding (singleton)
import Ledger.Constraints as Constraints
import qualified Ledger.Scripts as Scripts
import qualified Ledger.Typed.Scripts as Scripts
import Ledger.Ada as Ada
import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema)
import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions)
import Playground.Types (KnownCurrency (..))
import Prelude (Semigroup (..))
import Text.Printf (printf)
newtype DuoBoolRedeemer = DuoBoolRedeemer (Bool, Bool)
deriving (Generic, ToSchema)
PlutusTx.unstableMakeIsData ''DuoBoolRedeemer
{-# INLINABLE mkValidator #-}
-- This should validate if and only if the two Booleans in the redeemer are equal!
mkValidator :: () -> DuoBoolRedeemer -> ValidatorCtx -> Bool
mkValidator _ (DuoBoolRedeemer (b1,b2)) _ = traceIfFalse "wrong redeemer" $ b1 == b2
data Typed
instance Scripts.ScriptType Typed where
type instance DatumType Typed = ()
type instance RedeemerType Typed = DuoBoolRedeemer
inst :: Scripts.ScriptInstance Typed
inst = Scripts.validator #Typed
$$(PlutusTx.compile [|| mkValidator ||])
$$(PlutusTx.compile [|| wrap ||])
where
wrap = Scripts.wrapValidator #() #DuoBoolRedeemer
validator :: Validator
validator = Scripts.validatorScript inst
valHash :: Ledger.ValidatorHash
valHash = Scripts.validatorHash validator
scrAddress :: Ledger.Address
scrAddress = ScriptAddress valHash
type GiftSchema =
BlockchainActions
.\/ Endpoint "give" Integer
.\/ Endpoint "grab" DuoBoolRedeemer
give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
give amount = do
let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount
ledgerTx <- submitTxConstraints inst tx
void $ awaitTxConfirmed $ txId ledgerTx
logInfo #String $ printf "made a gift of %d lovelace" amount
grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => DuoBoolRedeemer -> Contract w s e ()
grab bs = do
utxos <- utxoAt scrAddress
let orefs = fst <$> Map.toList utxos
lookups = Constraints.unspentOutputs utxos <>
Constraints.otherScript validator
tx :: TxConstraints Void Void
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData bs | oref <- orefs]
ledgerTx <- submitTxConstraintsWith #Void lookups tx
void $ awaitTxConfirmed $ txId ledgerTx
logInfo #String $ "collected gifts"
endpoints :: Contract () GiftSchema Text ()
endpoints = (give' `select` grab') >> endpoints
where
give' = endpoint #"give" >>= give
grab' = endpoint #"grab" >>= grab
mkSchemaDefinitions ''GiftSchema
mkKnownCurrencies []
I don't understand why it fails. In the playground, for the "grab" action I have the message "Unsuported non record constructor". I think the problem is with ToSchema which may only accept reccords, but if I don't use it, I have an error message requiring it... I don't understand.
I'm no expert, but can you try a:
.\/ Endpoint "grab" (Bool, Bool)
Given that the simulator, imho, only expects simpler things

Haskell IO-Streams and Groundhog db usage

How to compile the following program? Somehow I cannot escape the error "No instance for (PersistBackend IO).
My aim is to see, how to efficiently fill a db-table using io-streams. The type of makeOutputStream is (Maybe a -> IO ()) -> IO (OutputStream a) while insertWords returns m () and it does not accept IO () as return type.
(Late addition: a work around found, but it is not an answer to the question. See below.)
The error msg is:
Words_read2.hs:30:36:
No instance for (PersistBackend IO)
arising from a use of `insertWord'
Possible fix: add an instance declaration for (PersistBackend IO)
In the first argument of `Streams.makeOutputStream', namely
`insertWord'
In a stmt of a 'do' block:
os <- Streams.makeOutputStream insertWord
In the expression:
do { is <- Streams.handleToInputStream h >>= Streams.words;
os <- Streams.makeOutputStream insertWord;
Streams.connect is os }
And the code producing this error is:
{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances, FlexibleContexts, StandaloneDeriving #-}
import qualified Data.ByteString as B
import Data.Maybe
import Control.Monad.IO.Class (MonadIO, liftIO)
import Database.Groundhog.Core
import Database.Groundhog.TH
import Database.Groundhog.Sqlite
import System.IO
import System.IO.Streams.File
import qualified System.IO.Streams as Streams
data Words = Words {word :: String} deriving (Eq, Show)
mkPersist defaultCodegenConfig [groundhog|
definitions:
- entity: Words
|]
insertWord :: (MonadIO m, PersistBackend m) => Maybe B.ByteString -> m ()
insertWord wo = case wo of
Just ww -> insert_ $ Words ((show . B.unpack) ww)
Nothing -> return ()
main = do
withSqliteConn "words2.sqlite" $ runDbConn $ do
runMigration defaultMigrationLogger $ migrate (undefined :: Words)
liftIO $ withFile "web2" ReadMode $ \h -> do -- a link to /usr/share/dict/web2 - a list of words one per line
is <- Streams.handleToInputStream h >>= Streams.words
os <- Streams.makeOutputStream insertWord
Streams.connect is os
As a work around, we can do things other way: we do not try to work inside runDbConn but rather return a handle to a (pool of) connection and pass it around. The idea come from SO answer to question:
Making Custom Instances of PersistBackend.
{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances, FlexibleContexts, StandaloneDeriving #-}
import qualified Data.ByteString as B
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Control.Monad.IO.Class -- (MonadIO, liftIO)
import Control.Monad.Trans.Control
import Database.Groundhog.Core
import Database.Groundhog.TH
import Database.Groundhog.Sqlite
import System.IO
import System.IO.Streams.File
import qualified System.IO.Streams as Streams
data Words = Words {word :: T.Text} deriving (Eq, Show)
mkPersist defaultCodegenConfig [groundhog|
definitions:
- entity: Words
|]
main = do
gh <- do withSqlitePool "words5.sqlite" 5 $ \pconn -> return pconn
runDbConn (runMigration defaultMigrationLogger $ migrate (undefined :: Words)) gh
withFile "web3" ReadMode $ \h -> do -- 500 words from /usr/share/dict/web2 - a list of words one per line
is <- Streams.handleToInputStream h >>= Streams.words
os <- Streams.makeOutputStream (iw2db gh)
Streams.connect is os
iw2db :: (MonadIO m, MonadBaseControl IO m, ConnectionManager cm Sqlite) => cm -> Maybe B.ByteString -> m()
iw2db gh (Just x) = runDbConn (insert_ $ Words (T.decodeUtf8 x)) gh
iw2db gh Nothing = return ()
Groundhog actions can run only in monad which is an instance of PersistBackend. IO cannot be made its instance because unlike DbPersist it does not carry connection information.
I like the code in the workaround, but can be made much faster. Now each action is run within its own transaction opened by runDbConn. To avoid this we can open a connection from pool and begin a single transaction. And then each action reuses this connection avoiding transaction overhead. Also createSqlitePool is nicer than withSqlitePool in this case.
{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances, FlexibleContexts, StandaloneDeriving #-}
import qualified Data.ByteString as B
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Control.Monad.IO.Class -- (MonadIO, liftIO)
import Control.Monad.Trans.Control
import Database.Groundhog.Core
import Database.Groundhog.TH
import Database.Groundhog.Sqlite
import System.IO
import System.IO.Streams.File
import qualified System.IO.Streams as Streams
import Control.Monad.Logger (MonadLogger, NoLoggingT(..))
data Words = Words {word :: T.Text} deriving (Eq, Show)
mkPersist defaultCodegenConfig [groundhog|
definitions:
- entity: Words
|]
main = do
gh <- createSqlitePool "words5.sqlite" 5
runDbConn (runMigration defaultMigrationLogger $ migrate (undefined :: Words)) gh
withFile "/usr/share/dict/words" ReadMode $ \h -> do -- 500 words from /usr/share/dict/web2 - a list of words one per line
is <- Streams.handleToInputStream h >>= Streams.words
withConn (\conn -> liftIO $ do -- (conn :: Sqlite) with opened transaction
os <- Streams.makeOutputStream (iw2db conn)
-- It is important to put Streams.connect inside withConn so that it uses the same transaction
-- If we put it outside, the transaction will be already closed and Sqlite will automatically do a new transaction for each insert
Streams.connect is os) gh
iw2db :: (MonadIO m, MonadBaseControl IO m, ConnectionManager cm Sqlite)
=> cm -> Maybe B.ByteString -> m ()
iw2db gh (Just x) = runDbConnNoTransaction (insert_ $ Words (T.decodeUtf8 x)) gh
iw2db gh Nothing = return ()
-- Probably this function should go to the Generic module
runDbConnNoTransaction :: (MonadBaseControl IO m, MonadIO m, ConnectionManager cm conn) => DbPersist conn (NoLoggingT m) a -> cm -> m a
runDbConnNoTransaction f cm = runNoLoggingT (withConnNoTransaction (runDbPersist f) cm)

Model validation in Yesod

I'd like to define a constraint on a field so reserved words are not valid. How can I accomplish this in Yesod?
{-# LANGUAGE TemplateHaskell #-}
module Sid where
import Control.Exception
import Data.List
import Database.Persist.TH
import Data.Aeson.TH
import Text.Show
import Text.Read
import Data.Text
data Sid = Sid Text
deriving (Show, Read)
reserved :: [Text]
reserved = ["abc","def"]
allowedSid :: Text -> Sid
allowedSid a = (assert (notElem a reserved)) Sid a
derivePersistField "allowedSid"
deriveJSON defaultOptions ''allowedSid
I'd do this in normal Haskell instead: create a newtype wrapper with some smart constructors. This would look something like:
newtype Sid = Sid Text
mkSid :: Text -> Maybe Sid
mkSid t = if t `elem` reserved then Nothing else Just t
Put this code in a module, and don't export the Sid data constructor.

Yesod Persistent functions inaccessible from Handler. What should I include?

I'm having trouble with a slightly altered Yesod scaffold. I've got my Entity described like so in /config/models:
Artist
ident Int
value Text
and here is my handler at /Handler/Artist.hs
{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell,
OverloadedStrings, GADTs, FlexibleContexts #-}
module Handler.Artist where
import Import
import qualified Control.Monad.IO.Class as M
import Text.Hamlet (shamlet)
import Text.Blaze.Html.Renderer.String (renderHtml)
import Database.Persist
import Database.Persist.Sqlite
import Database.Persist.TH
import Control.Monad.IO.Class (liftIO)
getArtistR = concatMap (renderListElement . value) $ artists
where artists = selectList ([] :: [Filter Artist]) []
renderListElement name = renderHtml [shamlet|<li>#{name}|]
(I included with redundancy :) )
And lastly, my errors:
Rebuilding application... (using cabal)
Handler/Artist.hs:14:45: Not in scope: `value'
Build failure, pausing...
I'm not sure what I should do! Do I need to throw in something like $(widgetFile "artist") in the handler? Where is the patching going wrong? Any help would be so awesome. Thank you in advance!!!
You should prefix functions with model name, so value becomes artistValue.
Documentation contains example of generated code.

Resources