Remove servant-examples
This commit is contained in:
Julian K. Arni
parent
637de9d63f
commit
c23a5ce90e
23 changed files with 0 additions and 1038 deletions
|
|
@ -1 +0,0 @@
|
||||||
../servant-examples/tutorial
|
|
||||||
|
|
@ -1,30 +0,0 @@
|
||||||
Copyright (c) 2015-2016, Servant Contributors
|
|
||||||
|
|
||||||
All rights reserved.
|
|
||||||
|
|
||||||
Redistribution and use in source and binary forms, with or without
|
|
||||||
modification, are permitted provided that the following conditions are met:
|
|
||||||
|
|
||||||
* Redistributions of source code must retain the above copyright
|
|
||||||
notice, this list of conditions and the following disclaimer.
|
|
||||||
|
|
||||||
* Redistributions in binary form must reproduce the above
|
|
||||||
copyright notice, this list of conditions and the following
|
|
||||||
disclaimer in the documentation and/or other materials provided
|
|
||||||
with the distribution.
|
|
||||||
|
|
||||||
* Neither the name of Alp Mestanogullari nor the names of other
|
|
||||||
contributors may be used to endorse or promote products derived
|
|
||||||
from this software without specific prior written permission.
|
|
||||||
|
|
||||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
|
||||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
|
||||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
|
||||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
|
||||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
|
||||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
|
||||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
|
||||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
|
||||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
|
||||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
|
||||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
|
|
@ -1,2 +0,0 @@
|
||||||
import Distribution.Simple
|
|
||||||
main = defaultMain
|
|
||||||
|
|
@ -1,96 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
|
|
||||||
import Data.Aeson
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
import Data.IORef
|
|
||||||
import Data.Text (Text)
|
|
||||||
import GHC.Generics
|
|
||||||
import Network.Wai
|
|
||||||
import Network.Wai.Handler.Warp
|
|
||||||
import Servant
|
|
||||||
import Servant.Server.Internal
|
|
||||||
|
|
||||||
-- Pretty much stolen/adapted from
|
|
||||||
-- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs
|
|
||||||
|
|
||||||
type DBConnection = IORef [ByteString]
|
|
||||||
type DBLookup = DBConnection -> ByteString -> IO Bool
|
|
||||||
|
|
||||||
initDB :: IO DBConnection
|
|
||||||
initDB = newIORef ["good password"]
|
|
||||||
|
|
||||||
isGoodCookie :: DBLookup
|
|
||||||
isGoodCookie ref password = do
|
|
||||||
allowed <- readIORef ref
|
|
||||||
return (password `elem` allowed)
|
|
||||||
|
|
||||||
data AuthProtected
|
|
||||||
|
|
||||||
instance (HasConfigEntry config DBConnection, HasServer rest config)
|
|
||||||
=> HasServer (AuthProtected :> rest) config where
|
|
||||||
|
|
||||||
type ServerT (AuthProtected :> rest) m = ServerT rest m
|
|
||||||
|
|
||||||
route Proxy config subserver = WithRequest $ \ request ->
|
|
||||||
route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request
|
|
||||||
where
|
|
||||||
cookieCheck req = case lookup "Cookie" (requestHeaders req) of
|
|
||||||
Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" }
|
|
||||||
Just v -> do
|
|
||||||
let dbConnection = getConfigEntry config
|
|
||||||
authGranted <- isGoodCookie dbConnection v
|
|
||||||
if authGranted
|
|
||||||
then return $ Route ()
|
|
||||||
else return $ FailFatal err403 { errBody = "Invalid cookie" }
|
|
||||||
|
|
||||||
type PrivateAPI = Get '[JSON] [PrivateData]
|
|
||||||
|
|
||||||
type PublicAPI = Get '[JSON] [PublicData]
|
|
||||||
|
|
||||||
type API = "private" :> AuthProtected :> PrivateAPI
|
|
||||||
:<|> PublicAPI
|
|
||||||
|
|
||||||
newtype PrivateData = PrivateData { ssshhh :: Text }
|
|
||||||
deriving (Eq, Show, Generic)
|
|
||||||
|
|
||||||
instance ToJSON PrivateData
|
|
||||||
|
|
||||||
newtype PublicData = PublicData { somedata :: Text }
|
|
||||||
deriving (Eq, Show, Generic)
|
|
||||||
|
|
||||||
instance ToJSON PublicData
|
|
||||||
|
|
||||||
api :: Proxy API
|
|
||||||
api = Proxy
|
|
||||||
|
|
||||||
server :: Server API
|
|
||||||
server = return prvdata :<|> return pubdata
|
|
||||||
|
|
||||||
where prvdata = [PrivateData "this is a secret"]
|
|
||||||
pubdata = [PublicData "this is a public piece of data"]
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
dbConnection <- initDB
|
|
||||||
let config = dbConnection :. EmptyConfig
|
|
||||||
run 8080 (serve api config server)
|
|
||||||
|
|
||||||
{- Sample session:
|
|
||||||
$ curl http://localhost:8080/
|
|
||||||
[{"somedata":"this is a public piece of data"}]
|
|
||||||
$ curl http://localhost:8080/private
|
|
||||||
Missing auth header.
|
|
||||||
$ curl -H "Cookie: good password" http://localhost:8080/private
|
|
||||||
[{"ssshhh":"this is a secret"}]
|
|
||||||
$ curl -H "Cookie: bad password" http://localhost:8080/private
|
|
||||||
Invalid cookie.
|
|
||||||
-}
|
|
||||||
|
|
@ -1,90 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Trans.Except
|
|
||||||
import Data.Aeson
|
|
||||||
import Data.Monoid
|
|
||||||
import Data.Proxy
|
|
||||||
import Data.Text (Text)
|
|
||||||
import GHC.Generics
|
|
||||||
import Network.HTTP.Client (Manager, defaultManagerSettings,
|
|
||||||
newManager)
|
|
||||||
import System.IO.Unsafe (unsafePerformIO)
|
|
||||||
import Servant.API
|
|
||||||
import Servant.Client
|
|
||||||
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Data.Text.IO as T
|
|
||||||
|
|
||||||
type HackageAPI =
|
|
||||||
"users" :> Get '[JSON] [UserSummary]
|
|
||||||
:<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed
|
|
||||||
:<|> "packages" :> Get '[JSON] [Package]
|
|
||||||
|
|
||||||
type Username = Text
|
|
||||||
|
|
||||||
data UserSummary = UserSummary
|
|
||||||
{ summaryUsername :: Username
|
|
||||||
, summaryUserid :: Int
|
|
||||||
} deriving (Eq, Show)
|
|
||||||
|
|
||||||
instance FromJSON UserSummary where
|
|
||||||
parseJSON (Object o) =
|
|
||||||
UserSummary <$> o .: "username"
|
|
||||||
<*> o .: "userid"
|
|
||||||
|
|
||||||
parseJSON _ = mzero
|
|
||||||
|
|
||||||
type Group = Text
|
|
||||||
|
|
||||||
data UserDetailed = UserDetailed
|
|
||||||
{ username :: Username
|
|
||||||
, userid :: Int
|
|
||||||
, groups :: [Group]
|
|
||||||
} deriving (Eq, Show, Generic)
|
|
||||||
|
|
||||||
instance FromJSON UserDetailed
|
|
||||||
|
|
||||||
newtype Package = Package { packageName :: Text }
|
|
||||||
deriving (Eq, Show, Generic)
|
|
||||||
|
|
||||||
instance FromJSON Package
|
|
||||||
|
|
||||||
hackageAPI :: Proxy HackageAPI
|
|
||||||
hackageAPI = Proxy
|
|
||||||
|
|
||||||
|
|
||||||
{-# NOINLINE manager #-}
|
|
||||||
manager :: Manager
|
|
||||||
manager = unsafePerformIO $ newManager defaultManagerSettings
|
|
||||||
|
|
||||||
getUsers :: ExceptT ServantError IO [UserSummary]
|
|
||||||
getUser :: Username -> ExceptT ServantError IO UserDetailed
|
|
||||||
getPackages :: ExceptT ServantError IO [Package]
|
|
||||||
getUsers :<|> getUser :<|> getPackages =
|
|
||||||
client hackageAPI (BaseUrl Http "hackage.haskell.org" 80 "") manager
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = print =<< uselessNumbers
|
|
||||||
|
|
||||||
uselessNumbers :: IO (Either ServantError ())
|
|
||||||
uselessNumbers = runExceptT $ do
|
|
||||||
users <- getUsers
|
|
||||||
liftIO . putStrLn $ show (length users) ++ " users"
|
|
||||||
|
|
||||||
user <- liftIO $ do
|
|
||||||
putStrLn "Enter a valid hackage username"
|
|
||||||
T.getLine
|
|
||||||
userDetailed <- getUser user
|
|
||||||
liftIO . T.putStrLn $ user <> " maintains " <> T.pack (show (length $ groups userDetailed)) <> " packages"
|
|
||||||
|
|
||||||
packages <- getPackages
|
|
||||||
let monadPackages = filter (isMonadPackage . packageName) packages
|
|
||||||
liftIO . putStrLn $ show (length monadPackages) ++ " monad packages"
|
|
||||||
|
|
||||||
where isMonadPackage = T.isInfixOf "monad"
|
|
||||||
|
|
@ -1,8 +0,0 @@
|
||||||
#if __GLASGOW_HASKELL__ >= 710
|
|
||||||
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
|
|
||||||
#define OVERLAPPING_ {-# OVERLAPPING #-}
|
|
||||||
#else
|
|
||||||
{-# LANGUAGE OverlappingInstances #-}
|
|
||||||
#define OVERLAPPABLE_
|
|
||||||
#define OVERLAPPING_
|
|
||||||
#endif
|
|
||||||
|
|
@ -1,130 +0,0 @@
|
||||||
name: servant-examples
|
|
||||||
version: 0.5
|
|
||||||
synopsis: Example programs for servant
|
|
||||||
description: Example programs for servant,
|
|
||||||
showcasing solutions to common needs.
|
|
||||||
homepage: http://haskell-servant.github.io/
|
|
||||||
license: BSD3
|
|
||||||
license-file: LICENSE
|
|
||||||
author: Servant Contributors
|
|
||||||
maintainer: haskell-servant-maintainers@googlegroups.com
|
|
||||||
copyright: 2015-2016 Servant Contributors
|
|
||||||
category: Web
|
|
||||||
build-type: Simple
|
|
||||||
cabal-version: >=1.10
|
|
||||||
bug-reports: http://github.com/haskell-servant/servant/issues
|
|
||||||
source-repository head
|
|
||||||
type: git
|
|
||||||
location: http://github.com/haskell-servant/servant.git
|
|
||||||
|
|
||||||
executable tutorial
|
|
||||||
main-is: tutorial.hs
|
|
||||||
other-modules: T1, T2, T3, T4, T5, T6, T7, T8, T9, T10
|
|
||||||
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-unused-imports
|
|
||||||
build-depends:
|
|
||||||
aeson >= 0.8
|
|
||||||
, base >= 4.7 && < 5
|
|
||||||
, bytestring
|
|
||||||
, directory
|
|
||||||
, http-types
|
|
||||||
, js-jquery
|
|
||||||
, lucid
|
|
||||||
, random
|
|
||||||
, servant == 0.5.*
|
|
||||||
, servant-docs == 0.5.*
|
|
||||||
, servant-js == 0.5.*
|
|
||||||
, servant-lucid == 0.5.*
|
|
||||||
, servant-server == 0.5.*
|
|
||||||
, text
|
|
||||||
, time
|
|
||||||
, transformers
|
|
||||||
, transformers-compat
|
|
||||||
, wai
|
|
||||||
, warp
|
|
||||||
hs-source-dirs: tutorial
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
||||||
executable t8-main
|
|
||||||
main-is: t8-main.hs
|
|
||||||
other-modules: T3, T8
|
|
||||||
hs-source-dirs: tutorial
|
|
||||||
default-language: Haskell2010
|
|
||||||
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing
|
|
||||||
build-depends:
|
|
||||||
aeson
|
|
||||||
, base >= 4.7 && < 5
|
|
||||||
, http-client > 0.4 && < 0.5
|
|
||||||
, servant == 0.5.*
|
|
||||||
, servant-client == 0.5.*
|
|
||||||
, servant-server == 0.5.*
|
|
||||||
, transformers
|
|
||||||
, transformers-compat
|
|
||||||
, wai
|
|
||||||
|
|
||||||
executable hackage
|
|
||||||
main-is: hackage.hs
|
|
||||||
build-depends:
|
|
||||||
aeson >= 0.8
|
|
||||||
, base >=4.7 && < 5
|
|
||||||
, http-client > 0.4 && < 0.5
|
|
||||||
, servant == 0.5.*
|
|
||||||
, servant-client == 0.5.*
|
|
||||||
, text
|
|
||||||
, transformers
|
|
||||||
, transformers-compat
|
|
||||||
hs-source-dirs: hackage
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
||||||
executable wai-middleware
|
|
||||||
main-is: wai-middleware.hs
|
|
||||||
build-depends:
|
|
||||||
aeson >= 0.8
|
|
||||||
, base >= 4.7 && < 5
|
|
||||||
, servant == 0.5.*
|
|
||||||
, servant-server == 0.5.*
|
|
||||||
, text
|
|
||||||
, wai
|
|
||||||
, wai-extra
|
|
||||||
, warp
|
|
||||||
hs-source-dirs: wai-middleware
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
||||||
executable auth-combinator
|
|
||||||
main-is: auth-combinator.hs
|
|
||||||
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing
|
|
||||||
build-depends:
|
|
||||||
aeson >= 0.8
|
|
||||||
, base >= 4.7 && < 5
|
|
||||||
, bytestring
|
|
||||||
, http-types
|
|
||||||
, servant == 0.5.*
|
|
||||||
, servant-server == 0.5.*
|
|
||||||
, text
|
|
||||||
, wai
|
|
||||||
, warp
|
|
||||||
hs-source-dirs: auth-combinator
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
||||||
executable socket-io-chat
|
|
||||||
main-is: socket-io-chat.hs
|
|
||||||
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing
|
|
||||||
other-modules: Chat
|
|
||||||
build-depends:
|
|
||||||
aeson >= 0.8
|
|
||||||
, base >= 4.7 && < 5
|
|
||||||
, bytestring
|
|
||||||
, http-types
|
|
||||||
, servant == 0.5.*
|
|
||||||
, servant-server == 0.5.*
|
|
||||||
, socket-io
|
|
||||||
, engine-io
|
|
||||||
, engine-io-wai
|
|
||||||
, text
|
|
||||||
, wai
|
|
||||||
, warp
|
|
||||||
, transformers
|
|
||||||
, stm
|
|
||||||
, mtl
|
|
||||||
ghc-options: -Wall -O2 -threaded
|
|
||||||
hs-source-dirs: socket-io-chat
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
@ -1,109 +0,0 @@
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE KindSignatures #-}
|
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
|
|
||||||
module Chat (eioServer, ServerState (..)) where
|
|
||||||
|
|
||||||
import Prelude hiding (mapM_)
|
|
||||||
|
|
||||||
#if !MIN_VERSION_base(4,8,0)
|
|
||||||
import Control.Applicative ((<$>), pure)
|
|
||||||
#endif
|
|
||||||
import Control.Monad.State.Class (MonadState)
|
|
||||||
import Control.Monad.IO.Class (MonadIO)
|
|
||||||
import Control.Monad.IO.Class (liftIO)
|
|
||||||
import Data.Aeson ((.=))
|
|
||||||
import Data.Foldable (mapM_)
|
|
||||||
|
|
||||||
import qualified Control.Concurrent.STM as STM
|
|
||||||
import qualified Data.Aeson as Aeson
|
|
||||||
import qualified Data.Text as Text
|
|
||||||
import qualified Network.SocketIO as SocketIO
|
|
||||||
|
|
||||||
|
|
||||||
data AddUser = AddUser Text.Text
|
|
||||||
|
|
||||||
instance Aeson.FromJSON AddUser where
|
|
||||||
parseJSON = Aeson.withText "AddUser" $ pure . AddUser
|
|
||||||
|
|
||||||
|
|
||||||
data NumConnected = NumConnected !Int
|
|
||||||
|
|
||||||
instance Aeson.ToJSON NumConnected where
|
|
||||||
toJSON (NumConnected n) = Aeson.object [ "numUsers" .= n]
|
|
||||||
|
|
||||||
|
|
||||||
data NewMessage = NewMessage Text.Text
|
|
||||||
|
|
||||||
instance Aeson.FromJSON NewMessage where
|
|
||||||
parseJSON = Aeson.withText "NewMessage" $ pure . NewMessage
|
|
||||||
|
|
||||||
|
|
||||||
data Said = Said Text.Text Text.Text
|
|
||||||
|
|
||||||
instance Aeson.ToJSON Said where
|
|
||||||
toJSON (Said username message) = Aeson.object
|
|
||||||
[ "username" .= username
|
|
||||||
, "message" .= message
|
|
||||||
]
|
|
||||||
|
|
||||||
data UserName = UserName Text.Text
|
|
||||||
|
|
||||||
instance Aeson.ToJSON UserName where
|
|
||||||
toJSON (UserName un) = Aeson.object [ "username" .= un ]
|
|
||||||
|
|
||||||
|
|
||||||
data UserJoined = UserJoined Text.Text Int
|
|
||||||
|
|
||||||
instance Aeson.ToJSON UserJoined where
|
|
||||||
toJSON (UserJoined un n) = Aeson.object
|
|
||||||
[ "username" .= un
|
|
||||||
, "numUsers" .= n
|
|
||||||
]
|
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
data ServerState = ServerState { ssNConnected :: STM.TVar Int }
|
|
||||||
|
|
||||||
--server :: ServerState -> StateT SocketIO.RoutingTable Snap.Snap ()
|
|
||||||
eioServer :: forall (m :: * -> *). (MonadState SocketIO.RoutingTable m, MonadIO m) => ServerState -> m ()
|
|
||||||
eioServer state = do
|
|
||||||
userNameMVar <- liftIO STM.newEmptyTMVarIO
|
|
||||||
let forUserName m = liftIO (STM.atomically (STM.tryReadTMVar userNameMVar)) >>= mapM_ m
|
|
||||||
|
|
||||||
SocketIO.on "new message" $ \(NewMessage message) ->
|
|
||||||
forUserName $ \userName ->
|
|
||||||
SocketIO.broadcast "new message" (Said userName message)
|
|
||||||
|
|
||||||
SocketIO.on "add user" $ \(AddUser userName) -> do
|
|
||||||
n <- liftIO $ STM.atomically $ do
|
|
||||||
n <- (+ 1) <$> STM.readTVar (ssNConnected state)
|
|
||||||
STM.putTMVar userNameMVar userName
|
|
||||||
STM.writeTVar (ssNConnected state) n
|
|
||||||
return n
|
|
||||||
|
|
||||||
SocketIO.emit "login" (NumConnected n)
|
|
||||||
SocketIO.broadcast "user joined" (UserJoined userName n)
|
|
||||||
|
|
||||||
SocketIO.appendDisconnectHandler $ do
|
|
||||||
(n, mUserName) <- liftIO $ STM.atomically $ do
|
|
||||||
n <- (+ (-1)) <$> STM.readTVar (ssNConnected state)
|
|
||||||
mUserName <- STM.tryReadTMVar userNameMVar
|
|
||||||
STM.writeTVar (ssNConnected state) n
|
|
||||||
return (n, mUserName)
|
|
||||||
|
|
||||||
case mUserName of
|
|
||||||
Nothing -> return ()
|
|
||||||
Just userName ->
|
|
||||||
SocketIO.broadcast "user left" (UserJoined userName n)
|
|
||||||
|
|
||||||
SocketIO.on "typing" $
|
|
||||||
forUserName $ \userName ->
|
|
||||||
SocketIO.broadcast "typing" (UserName userName)
|
|
||||||
|
|
||||||
SocketIO.on "stop typing" $
|
|
||||||
forUserName $ \userName ->
|
|
||||||
SocketIO.broadcast "stop typing" (UserName userName)
|
|
||||||
|
|
||||||
|
|
@ -1,28 +0,0 @@
|
||||||
<!doctype html>
|
|
||||||
<html lang="en">
|
|
||||||
<head>
|
|
||||||
<meta charset="UTF-8">
|
|
||||||
<title>Socket.IO Chat Example</title>
|
|
||||||
<link rel="stylesheet" href="style.css">
|
|
||||||
</head>
|
|
||||||
<body>
|
|
||||||
<ul class="pages">
|
|
||||||
<li class="chat page">
|
|
||||||
<div class="chatArea">
|
|
||||||
<ul class="messages"></ul>
|
|
||||||
</div>
|
|
||||||
<input class="inputMessage" placeholder="Type here..."/>
|
|
||||||
</li>
|
|
||||||
<li class="login page">
|
|
||||||
<div class="form">
|
|
||||||
<h3 class="title">What's your nickname?</h3>
|
|
||||||
<input class="usernameInput" type="text" maxlength="14" />
|
|
||||||
</div>
|
|
||||||
</li>
|
|
||||||
</ul>
|
|
||||||
|
|
||||||
<script src="https://cdn.socket.io/socket.io-1.2.1.js"></script>
|
|
||||||
<script src="https://code.jquery.com/jquery-1.10.2.min.js"></script>
|
|
||||||
<script src="/main.js"></script>
|
|
||||||
</body>
|
|
||||||
</html>
|
|
||||||
|
|
@ -1,274 +0,0 @@
|
||||||
$(function() {
|
|
||||||
var FADE_TIME = 150; // ms
|
|
||||||
var TYPING_TIMER_LENGTH = 400; // ms
|
|
||||||
var COLORS = [
|
|
||||||
'#e21400', '#91580f', '#f8a700', '#f78b00',
|
|
||||||
'#58dc00', '#287b00', '#a8f07a', '#4ae8c4',
|
|
||||||
'#3b88eb', '#3824aa', '#a700ff', '#d300e7'
|
|
||||||
];
|
|
||||||
|
|
||||||
// Initialize varibles
|
|
||||||
var $window = $(window);
|
|
||||||
var $usernameInput = $('.usernameInput'); // Input for username
|
|
||||||
var $messages = $('.messages'); // Messages area
|
|
||||||
var $inputMessage = $('.inputMessage'); // Input message input box
|
|
||||||
|
|
||||||
var $loginPage = $('.login.page'); // The login page
|
|
||||||
var $chatPage = $('.chat.page'); // The chatroom page
|
|
||||||
|
|
||||||
// Prompt for setting a username
|
|
||||||
var username;
|
|
||||||
var connected = false;
|
|
||||||
var typing = false;
|
|
||||||
var lastTypingTime;
|
|
||||||
var $currentInput = $usernameInput.focus();
|
|
||||||
|
|
||||||
var socket = io();
|
|
||||||
|
|
||||||
function addParticipantsMessage (data) {
|
|
||||||
var message = '';
|
|
||||||
if (data.numUsers === 1) {
|
|
||||||
message += "there's 1 participant";
|
|
||||||
} else {
|
|
||||||
message += "there're " + data.numUsers + " participants";
|
|
||||||
}
|
|
||||||
log(message);
|
|
||||||
}
|
|
||||||
|
|
||||||
// Sets the client's username
|
|
||||||
function setUsername () {
|
|
||||||
username = cleanInput($usernameInput.val().trim());
|
|
||||||
|
|
||||||
// If the username is valid
|
|
||||||
if (username) {
|
|
||||||
$loginPage.fadeOut();
|
|
||||||
$chatPage.show();
|
|
||||||
$loginPage.off('click');
|
|
||||||
$currentInput = $inputMessage.focus();
|
|
||||||
|
|
||||||
// Tell the server your username
|
|
||||||
socket.emit('add user', username);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
// Sends a chat message
|
|
||||||
function sendMessage () {
|
|
||||||
var message = $inputMessage.val();
|
|
||||||
// Prevent markup from being injected into the message
|
|
||||||
message = cleanInput(message);
|
|
||||||
// if there is a non-empty message and a socket connection
|
|
||||||
if (message && connected) {
|
|
||||||
$inputMessage.val('');
|
|
||||||
addChatMessage({
|
|
||||||
username: username,
|
|
||||||
message: message
|
|
||||||
});
|
|
||||||
// tell server to execute 'new message' and send along one parameter
|
|
||||||
socket.emit('new message', message);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
// Log a message
|
|
||||||
function log (message, options) {
|
|
||||||
var $el = $('<li>').addClass('log').text(message);
|
|
||||||
addMessageElement($el, options);
|
|
||||||
}
|
|
||||||
|
|
||||||
// Adds the visual chat message to the message list
|
|
||||||
function addChatMessage (data, options) {
|
|
||||||
// Don't fade the message in if there is an 'X was typing'
|
|
||||||
var $typingMessages = getTypingMessages(data);
|
|
||||||
options = options || {};
|
|
||||||
if ($typingMessages.length !== 0) {
|
|
||||||
options.fade = false;
|
|
||||||
$typingMessages.remove();
|
|
||||||
}
|
|
||||||
|
|
||||||
var $usernameDiv = $('<span class="username"/>')
|
|
||||||
.text(data.username)
|
|
||||||
.css('color', getUsernameColor(data.username));
|
|
||||||
var $messageBodyDiv = $('<span class="messageBody">')
|
|
||||||
.text(data.message);
|
|
||||||
|
|
||||||
var typingClass = data.typing ? 'typing' : '';
|
|
||||||
var $messageDiv = $('<li class="message"/>')
|
|
||||||
.data('username', data.username)
|
|
||||||
.addClass(typingClass)
|
|
||||||
.append($usernameDiv, $messageBodyDiv);
|
|
||||||
|
|
||||||
addMessageElement($messageDiv, options);
|
|
||||||
}
|
|
||||||
|
|
||||||
// Adds the visual chat typing message
|
|
||||||
function addChatTyping (data) {
|
|
||||||
data.typing = true;
|
|
||||||
data.message = 'is typing';
|
|
||||||
addChatMessage(data);
|
|
||||||
}
|
|
||||||
|
|
||||||
// Removes the visual chat typing message
|
|
||||||
function removeChatTyping (data) {
|
|
||||||
getTypingMessages(data).fadeOut(function () {
|
|
||||||
$(this).remove();
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
// Adds a message element to the messages and scrolls to the bottom
|
|
||||||
// el - The element to add as a message
|
|
||||||
// options.fade - If the element should fade-in (default = true)
|
|
||||||
// options.prepend - If the element should prepend
|
|
||||||
// all other messages (default = false)
|
|
||||||
function addMessageElement (el, options) {
|
|
||||||
var $el = $(el);
|
|
||||||
|
|
||||||
// Setup default options
|
|
||||||
if (!options) {
|
|
||||||
options = {};
|
|
||||||
}
|
|
||||||
if (typeof options.fade === 'undefined') {
|
|
||||||
options.fade = true;
|
|
||||||
}
|
|
||||||
if (typeof options.prepend === 'undefined') {
|
|
||||||
options.prepend = false;
|
|
||||||
}
|
|
||||||
|
|
||||||
// Apply options
|
|
||||||
if (options.fade) {
|
|
||||||
$el.hide().fadeIn(FADE_TIME);
|
|
||||||
}
|
|
||||||
if (options.prepend) {
|
|
||||||
$messages.prepend($el);
|
|
||||||
} else {
|
|
||||||
$messages.append($el);
|
|
||||||
}
|
|
||||||
$messages[0].scrollTop = $messages[0].scrollHeight;
|
|
||||||
}
|
|
||||||
|
|
||||||
// Prevents input from having injected markup
|
|
||||||
function cleanInput (input) {
|
|
||||||
return $('<div/>').text(input).text();
|
|
||||||
}
|
|
||||||
|
|
||||||
// Updates the typing event
|
|
||||||
function updateTyping () {
|
|
||||||
if (connected) {
|
|
||||||
if (!typing) {
|
|
||||||
typing = true;
|
|
||||||
socket.emit('typing');
|
|
||||||
}
|
|
||||||
lastTypingTime = (new Date()).getTime();
|
|
||||||
|
|
||||||
setTimeout(function () {
|
|
||||||
var typingTimer = (new Date()).getTime();
|
|
||||||
var timeDiff = typingTimer - lastTypingTime;
|
|
||||||
if (timeDiff >= TYPING_TIMER_LENGTH && typing) {
|
|
||||||
socket.emit('stop typing');
|
|
||||||
typing = false;
|
|
||||||
}
|
|
||||||
}, TYPING_TIMER_LENGTH);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
// Gets the 'X is typing' messages of a user
|
|
||||||
function getTypingMessages (data) {
|
|
||||||
return $('.typing.message').filter(function (i) {
|
|
||||||
return $(this).data('username') === data.username;
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
// Gets the color of a username through our hash function
|
|
||||||
function getUsernameColor (username) {
|
|
||||||
// Compute hash code
|
|
||||||
var hash = 7;
|
|
||||||
for (var i = 0; i < username.length; i++) {
|
|
||||||
hash = username.charCodeAt(i) + (hash << 5) - hash;
|
|
||||||
}
|
|
||||||
// Calculate color
|
|
||||||
var index = Math.abs(hash % COLORS.length);
|
|
||||||
return COLORS[index];
|
|
||||||
}
|
|
||||||
|
|
||||||
// Keyboard events
|
|
||||||
|
|
||||||
$window.keydown(function (event) {
|
|
||||||
// Auto-focus the current input when a key is typed
|
|
||||||
if (!(event.ctrlKey || event.metaKey || event.altKey)) {
|
|
||||||
$currentInput.focus();
|
|
||||||
}
|
|
||||||
// When the client hits ENTER on their keyboard
|
|
||||||
if (event.which === 13) {
|
|
||||||
if (username) {
|
|
||||||
sendMessage();
|
|
||||||
socket.emit('stop typing');
|
|
||||||
typing = false;
|
|
||||||
} else {
|
|
||||||
setUsername();
|
|
||||||
}
|
|
||||||
}
|
|
||||||
});
|
|
||||||
|
|
||||||
$inputMessage.on('input', function() {
|
|
||||||
updateTyping();
|
|
||||||
});
|
|
||||||
|
|
||||||
// Click events
|
|
||||||
|
|
||||||
// Focus input when clicking anywhere on login page
|
|
||||||
$loginPage.click(function () {
|
|
||||||
$currentInput.focus();
|
|
||||||
});
|
|
||||||
|
|
||||||
// Focus input when clicking on the message input's border
|
|
||||||
$inputMessage.click(function () {
|
|
||||||
$inputMessage.focus();
|
|
||||||
});
|
|
||||||
|
|
||||||
// Socket events
|
|
||||||
socket.on('connected', function (data) {
|
|
||||||
console.log('connected:', data);
|
|
||||||
});
|
|
||||||
|
|
||||||
// Socket events
|
|
||||||
socket.on('changes', function (data) {
|
|
||||||
console.log('changes:', data);
|
|
||||||
});
|
|
||||||
|
|
||||||
// Whenever the server emits 'login', log the login message
|
|
||||||
socket.on('login', function (data) {
|
|
||||||
connected = true;
|
|
||||||
// Display the welcome message
|
|
||||||
var message = "Welcome to Socket.IO Chat — ";
|
|
||||||
log(message, {
|
|
||||||
prepend: true
|
|
||||||
});
|
|
||||||
addParticipantsMessage(data);
|
|
||||||
});
|
|
||||||
|
|
||||||
// Whenever the server emits 'new message', update the chat body
|
|
||||||
socket.on('new message', function (data) {
|
|
||||||
addChatMessage(data);
|
|
||||||
});
|
|
||||||
|
|
||||||
// Whenever the server emits 'user joined', log it in the chat body
|
|
||||||
socket.on('user joined', function (data) {
|
|
||||||
log(data.username + ' joined');
|
|
||||||
addParticipantsMessage(data);
|
|
||||||
});
|
|
||||||
|
|
||||||
// Whenever the server emits 'user left', log it in the chat body
|
|
||||||
socket.on('user left', function (data) {
|
|
||||||
log(data.username + ' left');
|
|
||||||
addParticipantsMessage(data);
|
|
||||||
removeChatTyping(data);
|
|
||||||
});
|
|
||||||
|
|
||||||
// Whenever the server emits 'typing', show the typing message
|
|
||||||
socket.on('typing', function (data) {
|
|
||||||
addChatTyping(data);
|
|
||||||
});
|
|
||||||
|
|
||||||
// Whenever the server emits 'stop typing', kill the typing message
|
|
||||||
socket.on('stop typing', function (data) {
|
|
||||||
removeChatTyping(data);
|
|
||||||
});
|
|
||||||
});
|
|
||||||
|
|
@ -1,150 +0,0 @@
|
||||||
/* Fix user-agent */
|
|
||||||
|
|
||||||
* {
|
|
||||||
box-sizing: border-box;
|
|
||||||
}
|
|
||||||
|
|
||||||
html {
|
|
||||||
font-weight: 300;
|
|
||||||
-webkit-font-smoothing: antialiased;
|
|
||||||
}
|
|
||||||
|
|
||||||
html, input {
|
|
||||||
font-family:
|
|
||||||
"HelveticaNeue-Light",
|
|
||||||
"Helvetica Neue Light",
|
|
||||||
"Helvetica Neue",
|
|
||||||
Helvetica,
|
|
||||||
Arial,
|
|
||||||
"Lucida Grande",
|
|
||||||
sans-serif;
|
|
||||||
}
|
|
||||||
|
|
||||||
html, body {
|
|
||||||
height: 100%;
|
|
||||||
margin: 0;
|
|
||||||
padding: 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
ul {
|
|
||||||
list-style: none;
|
|
||||||
word-wrap: break-word;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Pages */
|
|
||||||
|
|
||||||
.pages {
|
|
||||||
height: 100%;
|
|
||||||
margin: 0;
|
|
||||||
padding: 0;
|
|
||||||
width: 100%;
|
|
||||||
}
|
|
||||||
|
|
||||||
.page {
|
|
||||||
height: 100%;
|
|
||||||
position: absolute;
|
|
||||||
width: 100%;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Login Page */
|
|
||||||
|
|
||||||
.login.page {
|
|
||||||
background-color: #000;
|
|
||||||
}
|
|
||||||
|
|
||||||
.login.page .form {
|
|
||||||
height: 100px;
|
|
||||||
margin-top: -100px;
|
|
||||||
position: absolute;
|
|
||||||
|
|
||||||
text-align: center;
|
|
||||||
top: 50%;
|
|
||||||
width: 100%;
|
|
||||||
}
|
|
||||||
|
|
||||||
.login.page .form .usernameInput {
|
|
||||||
background-color: transparent;
|
|
||||||
border: none;
|
|
||||||
border-bottom: 2px solid #fff;
|
|
||||||
outline: none;
|
|
||||||
padding-bottom: 15px;
|
|
||||||
text-align: center;
|
|
||||||
width: 400px;
|
|
||||||
}
|
|
||||||
|
|
||||||
.login.page .title {
|
|
||||||
font-size: 200%;
|
|
||||||
}
|
|
||||||
|
|
||||||
.login.page .usernameInput {
|
|
||||||
font-size: 200%;
|
|
||||||
letter-spacing: 3px;
|
|
||||||
}
|
|
||||||
|
|
||||||
.login.page .title, .login.page .usernameInput {
|
|
||||||
color: #fff;
|
|
||||||
font-weight: 100;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Chat page */
|
|
||||||
|
|
||||||
.chat.page {
|
|
||||||
display: none;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Font */
|
|
||||||
|
|
||||||
.messages {
|
|
||||||
font-size: 150%;
|
|
||||||
}
|
|
||||||
|
|
||||||
.inputMessage {
|
|
||||||
font-size: 100%;
|
|
||||||
}
|
|
||||||
|
|
||||||
.log {
|
|
||||||
color: gray;
|
|
||||||
font-size: 70%;
|
|
||||||
margin: 5px;
|
|
||||||
text-align: center;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Messages */
|
|
||||||
|
|
||||||
.chatArea {
|
|
||||||
height: 100%;
|
|
||||||
padding-bottom: 60px;
|
|
||||||
}
|
|
||||||
|
|
||||||
.messages {
|
|
||||||
height: 100%;
|
|
||||||
margin: 0;
|
|
||||||
overflow-y: scroll;
|
|
||||||
padding: 10px 20px 10px 20px;
|
|
||||||
}
|
|
||||||
|
|
||||||
.message.typing .messageBody {
|
|
||||||
color: gray;
|
|
||||||
}
|
|
||||||
|
|
||||||
.username {
|
|
||||||
float: left;
|
|
||||||
font-weight: 700;
|
|
||||||
overflow: hidden;
|
|
||||||
padding-right: 15px;
|
|
||||||
text-align: right;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Input */
|
|
||||||
|
|
||||||
.inputMessage {
|
|
||||||
border: 10px solid #000;
|
|
||||||
bottom: 0;
|
|
||||||
height: 60px;
|
|
||||||
left: 0;
|
|
||||||
outline: none;
|
|
||||||
padding-left: 10px;
|
|
||||||
position: absolute;
|
|
||||||
right: 0;
|
|
||||||
width: 100%;
|
|
||||||
}
|
|
||||||
|
|
@ -1,54 +0,0 @@
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
|
|
||||||
|
|
||||||
import Data.Monoid ((<>))
|
|
||||||
#if !MIN_VERSION_base(4,8,0)
|
|
||||||
import Control.Applicative ((<$>))
|
|
||||||
#endif
|
|
||||||
import Network.EngineIO.Wai
|
|
||||||
import Network.Wai
|
|
||||||
import Network.Wai.Handler.Warp (run)
|
|
||||||
import Servant
|
|
||||||
|
|
||||||
|
|
||||||
import qualified Control.Concurrent.STM as STM
|
|
||||||
import qualified Network.SocketIO as SocketIO
|
|
||||||
|
|
||||||
|
|
||||||
import Chat (ServerState (..), eioServer)
|
|
||||||
|
|
||||||
|
|
||||||
type API = "socket.io" :> Raw
|
|
||||||
:<|> Raw
|
|
||||||
|
|
||||||
|
|
||||||
api :: Proxy API
|
|
||||||
api = Proxy
|
|
||||||
|
|
||||||
|
|
||||||
server :: WaiMonad () -> Server API
|
|
||||||
server sHandler = socketIOHandler
|
|
||||||
:<|> serveDirectory "socket-io-chat/resources"
|
|
||||||
|
|
||||||
where
|
|
||||||
socketIOHandler req respond = toWaiApplication sHandler req respond
|
|
||||||
|
|
||||||
|
|
||||||
app :: WaiMonad () -> Application
|
|
||||||
app sHandler = serve api EmptyConfig $ server sHandler
|
|
||||||
|
|
||||||
port :: Int
|
|
||||||
port = 3001
|
|
||||||
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
state <- ServerState <$> STM.newTVarIO 0
|
|
||||||
sHandler <- SocketIO.initialize waiAPI (eioServer state)
|
|
||||||
putStrLn $ "Running on " <> show port
|
|
||||||
run port $ app sHandler
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -1,15 +0,0 @@
|
||||||
dependencies:
|
|
||||||
- name: servant
|
|
||||||
path: ../servant
|
|
||||||
- name: servant-server
|
|
||||||
path: ../servant-server
|
|
||||||
- name: servant-client
|
|
||||||
path: ../servant-client
|
|
||||||
- name: servant-js
|
|
||||||
path: ../servant-js
|
|
||||||
- name: servant-lucid
|
|
||||||
path: ../servant-lucid
|
|
||||||
- name: servant-docs
|
|
||||||
path: ../servant-docs
|
|
||||||
- name: servant-foreign
|
|
||||||
path: ../servant-foreign
|
|
||||||
|
|
@ -1,51 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
import Data.Aeson
|
|
||||||
import Data.Text
|
|
||||||
import GHC.Generics
|
|
||||||
import Network.Wai
|
|
||||||
import Network.Wai.Handler.Warp
|
|
||||||
import Network.Wai.Middleware.RequestLogger
|
|
||||||
import Servant
|
|
||||||
|
|
||||||
data Product = Product
|
|
||||||
{ name :: Text
|
|
||||||
, brand :: Text
|
|
||||||
, current_price_eur :: Double
|
|
||||||
, available :: Bool
|
|
||||||
} deriving (Eq, Show, Generic)
|
|
||||||
|
|
||||||
instance ToJSON Product
|
|
||||||
|
|
||||||
products :: [Product]
|
|
||||||
products = [p1, p2]
|
|
||||||
|
|
||||||
where p1 = Product "Haskell laptop sticker"
|
|
||||||
"GHC Industries"
|
|
||||||
2.50
|
|
||||||
True
|
|
||||||
|
|
||||||
p2 = Product "Foldable USB drive"
|
|
||||||
"Well-Typed"
|
|
||||||
13.99
|
|
||||||
False
|
|
||||||
|
|
||||||
type SimpleAPI = Get '[JSON] [Product]
|
|
||||||
|
|
||||||
simpleAPI :: Proxy SimpleAPI
|
|
||||||
simpleAPI = Proxy
|
|
||||||
|
|
||||||
server :: Server SimpleAPI
|
|
||||||
server = return products
|
|
||||||
|
|
||||||
-- logStdout :: Middleware
|
|
||||||
-- i.e, logStdout :: Application -> Application
|
|
||||||
-- serve :: Proxy api -> Config config -> Server api -> Application
|
|
||||||
-- so applying a middleware is really as simple as
|
|
||||||
-- applying a function to the result of 'serve'
|
|
||||||
app :: Application
|
|
||||||
app = logStdout (serve simpleAPI EmptyConfig server)
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = run 8080 app
|
|
||||||
Loading…
Reference in a new issue