haskellhaskell-snap-framework

How to combine postgresql snaplet and websockets?


The following code tries to combine two examples that work separately:

day 19 of 24 (2012) and e.g. ws example but I took almost everything websocket related away to get a small example.

Please, find the code below. The msgHandler is called by helloDb, which will get the the snaplet containing the db-connection and pass it to the msgHandler. The snaplet-posgresql-simple docs (at the end) give convenience instances and an example how to use one of them in the Initializer monad.

When I take the two commented lines away, ghc say that there are two instances involving out-of-scope types and that instances do overlapp: HasPostgres (ReaderT r m) and HasPostgres (ReaderT (Snaplet Postgres) m).

So the question is, how to get the program to compile so that I could pass db-connection from the snaplet to the websocket-part.

My goal is to make the websocket listen for messages, query db, and send messages pack. Other things that I already tried:

Is there a better approach to combining websockets and (db-) snaplets in snapframework? After trying several approaches I'm in serious mental lock state obviously needing help. Any help (even small hints about what kind of things I should start learning/refreshing), will be highly appreciated!

{-# LANGUAGE TemplateHaskell #-}                                                                                                                                                    
{-# LANGUAGE OverloadedStrings #-}                                                                                                                                                  

module Main where                                                                                                                                                                   

import Data.Maybe                                                                                                                                                                   
import Data.Monoid ((<>))                                                                                                                                                           
import Control.Lens                                                                                                                                                                 
import Control.Monad.Trans                                                                                                                                                          
import Control.Monad.Reader 
import Snap.Snaplet                                                                                                                                                                 
import Snap.Snaplet.PostgresqlSimple                                                                                                                                                
import Snap.Http.Server                                                                                                                                                             
import Snap.Core as SC                                                                                                                                                              
import Data.ByteString as BS                                                                                                                                                        
import Data.Text (Text)                                                                                                                                                             
import qualified Data.Text as T                                                                                                                                                     
import qualified Data.Text.IO as T                                                                                                                                                  
import qualified Network.WebSockets as WS                                                                                                                                           
import qualified Network.WebSockets.Snap as WS                                                                                                                                      

newtype App = App { _db :: Snaplet Postgres }                                                                                                                                       

makeLenses ''App                                                                                                                                                                    

msgHandler :: (MonadIO m) => App -> BS.ByteString -> WS.PendingConnection -> m ()                                                                                                   
msgHandler appSt mUId pending = do                                                                                                                                                  
  conn <- liftIO $ WS.acceptRequest pending                                                                                                                                         
  -- res <- liftIO $ runReaderT (query "SELECT name FROM users WHERE id = ?" (Only mUId)) dbSnaplet                                                                                 
  -- liftIO $ print (res :: [Name])                                                                                                                                                 
  liftIO $ T.putStrLn "msgHandler ended"                                                                                                                                            
    where dbSnaplet = view db appSt                                                                                                                                                 

initApp :: SnapletInit App App                                                                                                                                                      
initApp = makeSnaplet "myapp" "My application" Nothing $                                                                                                                            
  App <$> nestSnaplet "db" db pgsInit                                                                                                                                               
      <* addRoutes [("/hello/:id", helloDb)]                                                                                                                                        

newtype Name = Name { _nm :: Text } deriving (Show, Eq)                                                                                                                             

instance FromRow Name where fromRow = Name <$> field                                                                                                                                

helloDb :: Handler App App ()                                                                                                                                                       
helloDb = do                                                                                                                                                                        
  Just mUId <- getParam "id"                                                                                                                                                        
  userName <- with db $ listToMaybe <$> query "SELECT name FROM users     WHERE id = ?" (Only mUId)                                                                                     
  writeText $ maybe "User not found" (\h -> "Hello, " <> (T.pack . show) h) (userName :: Maybe Name)                                                                                
  sStApp <- getSnapletState                                                                                                                                                         
  WS.runWebSocketsSnap $ msgHandler (view snapletValue sStApp) mUId                                                                                                                 

main :: IO ()                                                                                                                                                                       
main = serveSnaplet defaultConfig initApp                                                                                                                                           

Solution

  • The overlapping instance issue you ran into is a bug in the snaplet-postgresql-simple library that has been fixed but the fix has not yet been released. You might want to ask the maintainer about this.

    In the meantime you can either pull the latest version of the library from Github, or redefine a type different but isomorphic to ReaderT (Snaplet Postgres), copying the HasPostgres instance.