Create a gist now

Instantly share code, notes, and snippets.

@imalsogreg /greet.hs
Last active Oct 17, 2015

What would you like to do?
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
import Control.Monad (mzero)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State (gets)
import Control.Lens hiding ((.=))
import Data.Aeson
import Data.ByteString.Char8 (pack)
import Data.IORef (IORef, newIORef, readIORef,
modifyIORef, writeIORef)
import Data.Proxy
import Data.Text hiding (pack)
import GHC.Generics
import Servant.Server.Internal.SnapShims
import Snap.Core (writeBS)
import Snap.Snaplet
import Snap.Snaplet.Auth
import Snap.Snaplet.Session
import Snap.Snaplet.Session.Backends.CookieSession
import Snap.Snaplet.Auth.Backends.JsonFile
import Snap.Snaplet.Heist
import Snap.Http.Server (defaultConfig)
import Snap.Http.Server.Config (setPort)
import Servant
import qualified Servant.JS as JS
import qualified Servant.JS.Internal as JSI
-- | Our simple class, `Item`, holding a name and a URL
data Item = Item
{ iname :: Text
, iurl :: Text
} deriving (Eq, Show, Ord, Generic)
-- 'deriving' makes Item a subclass of these other classes,
-- so we get `==`, `print`, `<`, and Reflection for `Item`
-- | A binary tree class for our `Item`s.
-- A single tree may be either:
data Tree =
TEmpty -- ^ The 'empty' tree
| TNode Item Tree Tree -- ^ Or a Node, containing a payload and
-- two sub-trees (which may themselves
-- be TEmpty or TNode _ _ _).
deriving (Eq, Ord, Show, Generic)
-- * Basic operations over trees
-- | insertT _O(log(n))_ takes an `Item` and an `Tree` and returns
-- a new `Tree` with the `Item` inserted.
-- We'll define the function in two parts: one for the case
-- when the `Tree` is `TEmpty` (the base case),
-- and another for the recursive/inductive case
insertT :: Item -> Tree -> Tree
insertT s TEmpty = TNode s TEmpty TEmpty
insertT s (TNode a l r)
| iname s < iname a = TNode a (insertT s l) r
| iname s >= iname a = TNode a l (insertT s r)
-- | deleteT _O(log(n))_ searches a `Tree` for an `Item` with a
-- given name, and returns the same tree with that node (and
-- all its children) deleted
-- Like insertT, deleteT function is defined in parts
deleteT :: Text -> Tree -> Tree
deleteT _ TEmpty = TEmpty
deleteT i (TNode a l r)
| i == iname a = TEmpty
| i < iname a = TNode a (deleteT i l) r
| i > iname a = TNode a l (deleteT i r)
-- | lookupT searches a `Tree` for an `Item` with a give name,
-- returning that `Item`s URL member if it finds a match, or
-- 'Nothing' if there is no match
lookupT :: Text -> Tree -> Maybe Text
lookupT _ TEmpty = Nothing
lookupT i (TNode a l r)
| i == iname a = Just $ iurl a
| i < iname a = lookupT i l
| i > iname a = lookupT i r
-- * Serialization
-- | How to turn a a `Item` into a JSON string
-- e.g. An `Item` with name "greg" and url "google.com"
-- should become '{"name":"greg", "url":"google.com"}'
instance ToJSON Item where
toJSON i =
object ["name" .= iname i, "url" .= iurl i]
-- | How to recover an `Item` from a JSON string
-- This is string parsing, which can be tricky,
-- so we will hide some of the complications of
-- error reporting and sequencing behind the
-- Applicative interface (something to chat
-- about later)
instance FromJSON Item where
parseJSON (Object v) =
Item <$> v .: "name" <*> v .: "url"
parseJSON _ = mzero
-- | The process is the same for turing `Tree`s into
-- strings and back. We can let the compiler write
-- these conversion functions for us, but let's
-- write them ourselves just to see their insides
--
-- A `TEmpty` should turn into the JSON `null` value,
-- A `TNode` should turn into a JSON `object` with
-- three fields: the payload, and (recursively) the
-- left and right subtrees
instance ToJSON Tree where
toJSON TEmpty = Null
toJSON (TNode a l r) = object ["payload" .= a
, "left" .= toJSON l
, "right" .= toJSON r
]
instance FromJSON Tree where
parseJSON Null = pure TEmpty
parseJSON (Object v) =
TNode <$>
v .: "payload" <*>
v .: "left" <*>
v .: "right"
parseJSON _ = mzero
-- * The web service
-- | API specification
-- Sections are mutually exclusive URL's tha the site will process
-- A web api is like a set of functions, but messier because
-- the 'functions' are called by the user on one computer, (the
-- client, usually a web browser), and evaluated on another, (the
-- server), then the results are sent back to the client.
--
-- The spec we define here provides enough information for us to
-- implement the the server, a web browser client, commant-line
-- clients, and user-facing documentation
type TestApi =
-- 'example.com/api/tree' will return a the `Tree` state, JSON
-- encoded
"tree" :> Get '[JSON] Tree
-- 'example.com/api/insert' will look for a JSON encoded `Item`
-- in the request body, add it to the tree state, and return
-- the new `Tree`, JSON encoded
:<|> "insert" :> ReqBody '[JSON] Item :> Post '[JSON] Tree
-- 'example.com/api/lookup?id=greg' will call `lookupT` on the
-- `Tree` living on the server and return the 'greg' node's
-- payload, encoded in JSON of course
:<|> "lookup" :> QueryParam "id" Text :> Get '[JSON] Text
-- 'example.com/api/delete?id=hunger' behaves similarly to
-- 'lookup' above, modifying the server's tree according to
-- the output of the `deleteT` function
:<|> "delete" :> QueryParam "id" Text :> Get '[JSON] Tree
-- 'example.com/api/undo' will swap the server's current and
-- backup `Tree`s
:<|> "undo" :> Get '[JSON] Tree
-- Define a class for our web app, call it `App`, give it
-- members for the various web-app things it needs (client sessions,
-- cookies, template generation, and our `Tree` member, and an
-- extra `Tree` used as a backup or undo operations)
data App = App {
_heist :: Snaplet (Heist App)
, _sess :: Snaplet SessionManager
, _auth :: Snaplet (AuthManager App)
, _gNow :: IORef Tree
, _gLast :: IORef Tree
}
makeLenses ''App
type AppHandler = Handler App App
testApi :: Proxy TestApi
testApi = Proxy
-- Server-side handlers.
--
-- There's one handler per endpoint, which, just like in the type
-- that represents the API, are glued together using :<|>.
--
-- Each handler runs in the 'EitherT ServantErr IO' monad.
server :: Server TestApi AppHandler
server = getTree :<|> postIns
:<|> getLookup :<|> getDel
:<|> getUndo
where backupState :: AppHandler ()
backupState = do
r <- gets _gNow
u <- gets _gLast
liftIO $ writeIORef u =<< readIORef r
getTree :: AppHandler Tree
getTree = do r <- gets _gNow; liftIO $ readIORef r
postIns :: Item -> AppHandler Tree
postIns v = do
backupState
r <- gets _gNow
t <- liftIO $ readIORef r
let t' = insertT v t
liftIO $ writeIORef r t'
return t'
getLookup :: Maybe Text -> AppHandler Text
getLookup (Just k) = do
r <- gets _gNow
t <- liftIO $ readIORef r
case lookupT k t of
Nothing -> error "Not found"
Just t -> return t
getDel :: Maybe Text -> AppHandler Tree
getDel (Just k) = do
backupState
r <- gets _gNow
liftIO $ modifyIORef r (deleteT k) >> readIORef r
getUndo :: AppHandler Tree
getUndo = do
u <- gets _gLast
r <- gets _gNow
lastTree <- liftIO $ readIORef u
backupState
liftIO $ writeIORef r lastTree
return lastTree
-- Turn the server into a Snap app. 'serve' is provided by servant,
-- more precisely by the Servant.Server module.
test :: Application AppHandler
test = serve testApi server
instance HasHeist App where
heistLens = subSnaplet heist
initApp :: SnapletInit App App
initApp = makeSnaplet "myapp" "An example app in servant" Nothing $ do
h <- nestSnaplet "" heist $ heistInit "templates"
s <- nestSnaplet "sess" sess $
initCookieSessionManager "site_key.txt" "sess"
Nothing (Just 3600)
a <- nestSnaplet "" auth $
initJsonFileAuthManager defAuthSettings sess "users.json"
addRoutes [("api", applicationToSnap test)
,("docs", handleDocs)
,("", serveDirectory "static")]
r <- liftIO $ newIORef TEmpty
u <- liftIO $ newIORef TEmpty
return $ App h s a r u
handleDocs :: Handler App App ()
handleDocs = writeBS (pack $ JS.jsForAPI testApi (JS.jqueryWith
(JS.defCommonGeneratorOptions {JSI.urlPrefix = "api"})))
-- Run the server.
--
runTestServer :: Int -> IO ()
runTestServer port = serveSnaplet (setPort port defaultConfig)
initApp
-- Put this all to work!
main :: IO ()
main = runTestServer 8001
<html><head>
<script src="//code.jquery.com/jquery-1.11.3.min.js"></script>
<script src="/docs"></script>
<style>
body { background-color: #eee;}
.node-div { background-color: #bbb; }
.child-div-left, .child-div-right { width: 49%; margin: 5px; }
.child-div-left { }
.child-div-right { }
.pic-div { display:flex; flex-flow: column nowrap; align-items: center; }
.pic { }
.pic-label { }
.children-div { display: flex; flex-flow: row nowrap;}
.node-div { }
.hbar { background-color: black; height: 3px; width: 100%;}
.vbar { background-color: black; width: 3px; height: 100%;}
</style>
<script>
// Lookup url by name
function lclick() {
sbox = document.getElementById('lbox');
rbox = document.getElementById('lresponse');
getLookup(sbox.value, function(b) { rbox.innerHTML = b.toString() }, function () { alert('error');});
}
// Get the whole tree and render it
function fetchAndDraw() {
drawingArea = document.getElementById('drawing-area');
drawingArea.innerHTML = '';
getTree( function(r) { drawTree(r, drawingArea, 256); }, function() {alert('Failed');} );
}
// Delete item and subtrees by name
function dclick() {
dbox = document.getElementById('dbox');
getDelete( dbox.value, function(b) {}, function () {alert('error');});
fetchAndDraw();
}
// Insert new Item object
function iclick() {
iname = document.getElementById('ibox');
iurl = document.getElementById('iurl');
b = {};
b.name = iname.value;
b.url = iurl.value;
postInsert( b, function () { bclick(); }, function () { alert('error') });
}
// Render the tree recursively
function drawTree(tree,p,len) {
if(tree == null) { console.log("Draw null"); }
else{
var nodeDiv = document.createElement('div');
nodeDiv.setAttribute('class','node-div');
p.appendChild(nodeDiv);
var d = document.createElement('div');
var picdiv = document.createElement('div');
picdiv.setAttribute('class','pic-div');
var picLabel = document.createElement('p');
picLabel.setAttribute('class','pic-label');
picLabel.innerHTML = tree.payload.name;
var pic = document.createElement('img');
pic.setAttribute('src', tree.payload.url);
pic.setAttribute('class','pic');
pic.setAttribute('width', len.toString() );
pic.setAttribute('height', len.toString() );
picdiv.appendChild(pic);
picdiv.appendChild(picLabel);
d.appendChild(picdiv);
nodeDiv.appendChild(d);
h = document.createElement('div');
h.setAttribute('class','hbar');
nodeDiv.appendChild(h);
var childrenDiv = document.createElement('div');
childrenDiv.setAttribute('class','children-div');
nodeDiv.appendChild(childrenDiv);
var leftChildDiv = document.createElement('div');
leftChildDiv.setAttribute('class','child-div-left');
childrenDiv.appendChild(leftChildDiv);
var vbar = document.createElement('div');
vbar.setAttribute('class','vbar');
childrenDiv.appendChild(vbar);
var rightChildDiv = document.createElement('div');
rightChildDiv.setAttribute('class','child-div-right');
childrenDiv.appendChild(rightChildDiv);
drawTree( tree.left, leftChildDiv, 50 );
drawTree( tree.right, rightChildDiv, 50 );
}
}
</script>
</head>
<body onload='fetchAndDraw()'>
<input type="text" id="lbox"></input>
<button id="test2" onclick="lclick()"/>Lookup</button>
<div id="lresponse"></div>
<hr/>
<input type="text" id="dbox"></input>
<button id="test3" onclick="dclick();"/>Delete</button>
<hr/>
<input type="text" id="ibox"></input>
<input type="text" id="iurl"></input>
<button id="test4" onclick="iclick()"/>Insert</button>
<hr/>
<button id="test5" onclick="getUndo(); fetchAndDraw()"/>Undo</button>
<div id="drawing-area"></div>
</body>
</html>
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment