From 7e3bdb76d0c21b9e49f826d3fd1b53008d604fbb Mon Sep 17 00:00:00 2001 From: Joscha Date: Sat, 27 Jan 2018 11:55:08 +0000 Subject: [PATCH] Initial commit --- .gitignore | 3 + ChangeLog.md | 3 + LICENSE | 30 ++++++++ README.md | 1 + Setup.hs | 2 + package.yaml | 43 ++++++++++++ src/EuphApi.hs | 5 ++ src/EuphApi/Controller.hs | 1 + src/EuphApi/Threads.hs | 134 ++++++++++++++++++++++++++++++++++++ src/EuphApi/Types.hs | 139 ++++++++++++++++++++++++++++++++++++++ stack.yaml | 66 ++++++++++++++++++ test/Spec.hs | 2 + 12 files changed, 429 insertions(+) create mode 100644 .gitignore create mode 100644 ChangeLog.md create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 package.yaml create mode 100644 src/EuphApi.hs create mode 100644 src/EuphApi/Controller.hs create mode 100644 src/EuphApi/Threads.hs create mode 100644 src/EuphApi/Types.hs create mode 100644 stack.yaml create mode 100644 test/Spec.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..d690797 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +.stack-work/ +euph-api.cabal +*~ \ No newline at end of file diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..4bb2f7a --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for euph-api + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..5714ffc --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Joscha Mennicken (c) 2018 + +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 Joscha Mennicken 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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..33590d7 --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# euph-api diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..703f5ff --- /dev/null +++ b/package.yaml @@ -0,0 +1,43 @@ +name: euph-api +version: 0.1.0.0 +github: "Garmelon/euph-api" +license: BSD3 +author: "Joscha Mennicken" +maintainer: "joscha@migejolise.de" +copyright: "Joscha Mennicken" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on Github at + +dependencies: +- base >= 4.7 && < 5 +- time +- websockets +- wuss +- text +- aeson +- bytestring + +library: + source-dirs: src + +tests: + euph-api-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - euph-api diff --git a/src/EuphApi.hs b/src/EuphApi.hs new file mode 100644 index 0000000..01c0ae3 --- /dev/null +++ b/src/EuphApi.hs @@ -0,0 +1,5 @@ +module EuphApi + ( module EuphApi.Types + ) where + +import EuphApi.Types diff --git a/src/EuphApi/Controller.hs b/src/EuphApi/Controller.hs new file mode 100644 index 0000000..7aebb67 --- /dev/null +++ b/src/EuphApi/Controller.hs @@ -0,0 +1 @@ +module EuphApi.Controller where diff --git a/src/EuphApi/Threads.hs b/src/EuphApi/Threads.hs new file mode 100644 index 0000000..5dbef0b --- /dev/null +++ b/src/EuphApi/Threads.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-- | Setup consisting of a few threads to send and receive packets to and from +-- the euphoria api using a websocket connection. + +module EuphApi.Threads ( + -- * Events and replies + Failure(..) + -- * Functions for using the api + , send + , reply + ) where + +import Control.Concurrent +import Control.Exception +import Data.Aeson +import Data.Text +import qualified EuphApi.Types as E +import qualified Network.WebSockets as WS + +-- Some useful type aliases +type PacketID = Text + +{- + - Events and replies + -} + +-- | The ways in which getting a reply from the server can fail. +data Failure = FailDisconnect -- ^ Disconnected from the server while waiting for the reply. + | FailParse -- ^ Could not parse the server's reply correctly. + +-- send-reply +data SendReply = SendReply + { sendReplyMessage :: E.Message + } deriving (Show) + +instance FromJSON SendReply where + parseJSON v = SendReply <$> parseJSON v + +{- + - API functions + -} + +send :: SendChan -> Text -> IO (Either Failure E.Message) +send = undefined + +reply :: SendChan -> PacketID -> Text -> IO (Either Failure E.Message) +reply = undefined + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{- +data Packet = Packet + { packetID :: Maybe PacketID + , packetType :: Text + , packetContent :: Content + , packetThrottled :: Maybe Text + } +-} + +type SendChan = Chan Send +-- Contents of sendChan +data Send = SPacket Text --Value -- packet type, content + | SDisconnect + +type RecvChan = Chan Recv +-- Contents of recvChan +data Recv = RConnectionClosed -- Ws connection closed +-- | RPacket ByteString -- Packet received from the ws connection +-- | forall c . (FromJSON c) => RReply PacketID (MVar (Response c)) -- Request for a reply with a certain ID + +{- +sendPacket :: Connection -> Packet -> IO () +sendPacket = undefined + +recvPacket :: Connection -> IO Packet +recvPacket = undefined + +sendThread :: SendChan -> RecvChan -> Connection -> IO () +sendThread s r c = do + return () + +type EventChan = Chan Event +-- Contents of eventChan +data Event = EPlaceholder + +fetchMessage :: RecvChan -> Connection -> IO () +fetchMessage recv con = do + message <- receiveData con + writeChan recv (RPacket message) + fetchMessage recv con + +fetchThread :: RecvChan -> Connection -> IO () +fetchThread recv con = fetchMessage recv con `catch` handleException + where + handleException (CloseRequest _ _) = writeChan recv RConnectionClosed + handleException ConnectionClosed = writeChan recv RConnectionClosed + handleException _ = fetchThread recv con + +sendMessage :: SendChan -> RecvChan -> Connection -> IO () +sendMessage send recv con = do + message <- readChan send + return () + +sendThread :: SendChan -> RecvChan -> Connection -> IO () +sendThread = undefined +-} diff --git a/src/EuphApi/Types.hs b/src/EuphApi/Types.hs new file mode 100644 index 0000000..631f0da --- /dev/null +++ b/src/EuphApi/Types.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | This module implements parts of the Euphoria API at +-- . +-- +-- Currently, accounts are not implemented. +-- This means that all account, room host and staff commands are not implemented. + +module EuphApi.Types + ( Snowflake + , SessionID + , UserID(..) + , UserType(..) + , Message(..) + , SessionView(..) + ) where + +import Data.Aeson +import Data.Function +import qualified Data.Text as T +import Data.Time + +-- | Represents . +-- +-- A 'Snowflake' is a 13-character string, usually used as a unique identifier for some type of object. +-- It is the base-36 encoding of an unsigned, 64-bit integer. +type Snowflake = T.Text + +-- | ID of a session, unique across all sessions globally. +type SessionID = T.Text + +-- | Represents . +-- +-- A 'UserID' identifies a user. +-- The type of session, 'UserType', can be retrieved via 'userType'. +data UserID = UserID + { userType :: UserType + , userSnowflake :: Snowflake + } deriving (Show, Eq) + +instance FromJSON UserID where + parseJSON = withText "UserID" $ \t -> + let (tp, sf) = T.breakOn ":" t + userType = findUserType tp + userSnowflake = T.drop 1 sf + in return $ if userType == Other + then UserID {userSnowflake=t, ..} + else UserID {..} + where + findUserType txt + | txt == "account" = Account + | txt == "bot" = Bot + | txt == "agent" = Agent + | otherwise = Other + + +-- | Whether a user is logged in, out, or a bot. +-- +-- See for more info. +data UserType = Agent + | Account + | Bot + | Other + deriving (Show, Eq) + +-- | Represents . +-- +-- A 'Message' is a node in a Room’s Log. +-- It corresponds to a chat message, or a post, or any broadcasted event in a room that should appear in the log. +-- +-- The fields @previous_edit_id@ and @encryption_key_id@ are not implemented. +data Message = Message + { msgID :: Snowflake + -- ^ The id of the message (unique within a room) + , msgParent :: Maybe Snowflake + -- ^ The id of the message's parent, or Nothing if top-level + , msgTime :: UTCTime + -- ^ The unix timestamp of when the message was posted + , msgSender :: SessionView + -- ^ The view of the sender's session + , msgContent :: String + -- ^ The content of the message (client-defined) + , msgEdited :: Maybe UTCTime + -- ^ The unix timestamp of when the message was last edited + , msgDeleted :: Maybe UTCTime + -- ^ The unix timestamp of when the message was deleted + , msgTruncated :: Bool + -- ^ If true, then the full content of this message is not included. + + -- , msgPreviousEditId :: MaybeSnowflake -- not implemented + -- , msgEncryptionKeyID :: String -- not implemented + } deriving (Show) + +instance Eq Message where + (==) = (==) `on` msgID + +instance Ord Message where + compare = compare `on` msgID + +instance FromJSON Message where + parseJSON = withObject "Message" $ \o -> do + msgID <- o .: "id" + msgParent <- o .:? "parent" + msgTime <- o .: "time" + msgSender <- o .: "sender" + msgContent <- o .: "content" + msgEdited <- o .:? "edited" + msgDeleted <- o .:? "deleted" + msgTruncated <- o .:? "truncated" .!= False + return $ Message {..} + +-- | Represents . +-- +-- A 'SessionView' describes a session and its identity. +-- +-- The fields @client_address@ and @real_client_address@ are not implemented. +data SessionView = SessionView + { sessID :: UserID + , sessName :: String + , sessServerID :: String + , sessServerEra :: String + , sessSessionID :: SessionID + , isStaff :: Bool + , isManager :: Bool + -- , sessClientAddress :: String -- not implemented + -- , sessRealClientAddress :: String -- not implemented + } deriving (Show) + +instance FromJSON SessionView where + parseJSON = withObject "SessionView" $ \o -> do + sessID <- o .: "id" + sessName <- o .: "name" + sessServerID <- o .: "server_id" + sessServerEra <- o .: "server_era" + sessSessionID <- o .: "session_id" + isStaff <- o .:? "is_staff" .!= False + isManager <- o .:? "is_manager" .!= False + return $ SessionView {..} diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..005cfcf --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-10.3 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.6" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor \ No newline at end of file diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"