{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric, ScopedTypeVariables #-}
import Data.Generics (Data, Typeable)
import Data.Conduit
import qualified Data.Conduit.List as CL
import Database.CouchDB.Conduit.Generic
import Database.CouchDB.Conduit
import Database.CouchDB.Conduit.View
import Data.ByteString.Char8 (ByteString, empty)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson
import Data.Aeson.Types
import GHC.Generics
data Page = Page { id_ :: ByteString, url :: ByteString }
deriving (Show, Data, Typeable, Generic)
instance FromJSON Page
getPages :: IO ()
getPages = runCouch (def { couchHost = "192.168.0.103" }) $ do
couchView_ "reader" "reader" "pages" [] $ CL.mapM_ (liftIO . print)
This works and gives me this:
*Main> getPages
fromList [("key",String "802e343945c7f8da2d8a71fdb80025a7"),("id",String "802e343945c7f8da2d8a71fdb80025a7"),("value",String "http://yandex.ru")]`
But I actually want a function getPages :: IO [Page], so I tried this:
getPages = runCouch (def { couchHost = "192.168.0.103" }) $ do
couchView_ "reader" "reader" "pages" [] $ toType =$ CL.consume`
which gives me type error:
`Reader/Couch.hs:24:47:
Couldn't match expected type `Object' with actual type `Value'
Expected type: Conduit Object m1 b0
Actual type: Conduit Value m0 a0
In the first argument of `(=$)', namely `toType'
In the second argument of `($)', namely `toType =$ CL.consume'
Failed, modules loaded: none.
This is not surprising because couchView needs Sink Object m a as a parameter.
The question is: how to implement getPages :: IO [Page]?
I'm not familiar with conduit, aeson, or couchDB, but this at least type-checks:
getPages :: IO [Result Page]
getPages = runCouch (def { couchHost = "192.168.0.103" }) $ do
couchView_ "reader" "reader" "pages" [] $ CL.map (fromJSON . Object) =$ CL.consume
Related
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
Is there any way I can test that a function p :: IsString s => s -> Bool evaluates its input lazily? That is, it only consumes a part of its input when determining its result. And is it possible in such a way that it's compatible with both String and Data.Text.Lazy?
I've looked at the Q&A Unit-testing the undefined evaluated in lazy expression in Haskell, which doesn't cover IsString specifically, and I've found the StrictCheck package on Hackage that I'm not really sure how works. Does it apply here?
Problem
I've got a predicate,
p :: IsString s => s -> Bool
and an Hspec test,
{-# LANGUAGE OverloadedStrings #-}
...
import Data.String (fromString)
spec_p :: Spec
spec_p =
describe "p" $
it "is lazy" $ p (fromString x) `shouldBe` y
where
x = "foo" ++ [undefined]
y = True
that fails if p ("foo" ++ [undefined]) tries to consume any more than "foo".
This works fine for my String implementation,
import qualified Data.List as L
p :: String -> Bool
p = ("foo" `L.isPrefixOf`)
But it does not work so fine on my Data.Text.Lazy implementation,
{-# LANGUAGE OverloadedStrings #-}
import qualified Data.Text.Lazy as T
import Data.Text.Lazy (Text)
p :: Text -> Bool
p = ("foo" `T.isPrefixOf`)
because fromString does not convert the lazy String into a lazy Text in a way that preserves the undefined unevaluated. I can test that the lazy version does work by writing a specialized test,
pTest :: Bool
pTest = p (T.fromChunks [ "foo", undefined ]) -- True
but I can't control how fromString chunks.
Attempted solution:
I tried to write my own wrapper to control the chunking of fromString,
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
newtype LazyChunkyText = LazyChunkyText LT.Text deriving (Show)
instance IsString LazyChunkyText where
fromString = LazyChunkyText . LT.fromChunks . map (T.pack . return)
But because fromChunks takes a [T.Text], I need to T.pack.
Meaning my [undefined] gets evaluated.
I am trying to get back a value that is in a json feed (via Aeson) directly inside a StateT stacked on IO:
{-# LANGUAGE DeriveGeneric #-}
module MyFeed where
import Data.Aeson
import Network.URI (parseURI, URI(..))
import Data.Maybe (fromJust)
import Data.Text (Text, unpack)
import Control.Monad.State
import Network.HTTP
import GHC.Generics
import Control.Applicative
import Network.HTTP.Conduit (simpleHttp)
import qualified Data.ByteString.Lazy as B
type Feed a = StateT MyIndex IO a
data MyIndex = MyIndex {
index :: Int
}
data FooBar = Foo | Bar
data MyFeed = MyFeed {
idx :: !Text,
key :: !Text
} deriving (Show,Generic)
instance FromJSON MyFeed
instance ToJSON MyFeed
getJSON :: String -> IO B.ByteString
getJSON url = simpleHttp url
getFeed :: String -> IO (Maybe MyFeed)
getFeed url = (decode <$> getJSON url) :: IO (Maybe MyFeed)
getIndex :: FooBar -> Feed MyIndex
getIndex fb = do
cursor <- get
let newCursor = case fb of
Foo -> do myFeed <- liftIO $ getFeed "http://echo.jsontest.com/key/value/idx/1"
let i = read $ unpack $ idx $ fromJust myFeed
return $ cursor { index = i }
Bar -> return cursor
put newCursor
return newCursor
In the Foo case I fetch the feed as expected but when the required value is returned I get:
src/MyFeed.hs:47:10:
Couldn't match expected type ‘MyIndex’
with actual type ‘m0 MyIndex’
Relevant bindings include
newCursor :: m0 MyIndex (bound at src/MyFeed.hs:40:7)
In the first argument of ‘return’, namely ‘newCursor’
In a stmt of a 'do' block: return newCursor
The Actual Type looks still in a Monad context (do {...}). Is there a way to take it out or I am using a wrong approach?
The error was due to the fact I used:
let newCursor = case fb of
instead of
newCursor <- case fb of
For this reason the final value never get "unwrapped" from its monad context.
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)
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.