├── .gitignore ├── ChangeLog.md ├── LICENSE ├── Readme.markdown ├── Setup.hs ├── app ├── client.hs └── server.hs ├── cabal.project.freeze ├── irc-simple.cabal ├── src ├── Client.hs ├── Protocol.hs ├── Protocol │ ├── Errors.hs │ ├── Parser.hs │ ├── Replies.hs │ ├── Types.hs │ └── Wire.hs ├── Server.hs ├── Server │ ├── Channel.hs │ ├── Handler.hs │ ├── Internal.hs │ └── User.hs └── Uni.hs └── tests ├── Test └── Protocol │ └── Parser.hs └── unit.hs /.gitignore: -------------------------------------------------------------------------------- 1 | cabal.project.local 2 | dist 3 | dist-newstyle 4 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for irc-simple 2 | 3 | ## 0.1.0.0 -- 2018-03-22 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Alexander Vershilov 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alexander Vershilov nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Readme.markdown: -------------------------------------------------------------------------------- 1 | Простой tcp сервер для показа, как можно писать такие сервера на Haskell. 2 | Делать только сам транспортный уровень не очень интересно, 3 | и, хотя он и достаточно простой, без более высокоуровневой логики 4 | пример не показательный. 5 | 6 | Конечно, за один вечер сделать нормальный irc сервер тяжело, если 7 | это конечно, не задача, на основе которой вы изучаете языки, как 8 | некоторые делают. Поэтому был реализован достаточно маленький 9 | сабсет, и подключить сервер к реальной irc сети будет нельзя. К 10 | тому же при реализации я решил продемонстрировать некоторые интересные 11 | моменты, которые могут быть бесполезны, или даже скорее вредны 12 | в реальном irc сервере. 13 | 14 | Также на этом проекте я не упустил возможности пописать интересные 15 | мне вещи, поэтому написал его не совсем в том стиле, в котором обычно 16 | я пишу. В коде не были использованы некоторые популярные и нравящиеся 17 | мне паттерны, такие как: 18 | 19 | 1. Service/Handle pattern - паттерн для разделения отвественности 20 | и инъекции зависимостей. 21 | 22 | 2. Использование расширяемых исключений - расширяемые исключения 23 | достаточно старый и успешно используемый framework, но в данном 24 | случае я предпочел его переизобрести и сделать код, который 25 | явно отражает возможные ошибки в типе функций. 26 | 27 | 3. Не использованы unliftio/safeexceptions и т.п. которые весьма 28 | спорные, хотя и могут уменьшить количество бойлерплейта 29 | 30 | В целом я попытался сделать достаточно простой учебный проект, по 31 | которому, с одной стороны, можно рассказать, что и как работает, а 32 | с другой его можно рефакторить изменять и улучшать. 33 | 34 | Я постараюсь добавить комментарии ко всему, что происходит, но рекомендованный 35 | порядок просмотра - сверху-вниз: 36 | 37 | 1. app/server.hs - описание исполняемого файла разбор опций/ 38 | 2. src/Server.hs - описание серверной части, собственно на этом месте 39 | можно и закончить просмотр для тех, кому интересно только это 40 | 3. src/Server/Handler.hs - описание пользовательских обработчиков 41 | 4. src/Server/{Channel,User}.hs - серверная логика для работы с каналами 42 | и пользователями. 43 | 5. src/Server/Internal.hs - внутренняя серверная логика и разговор 44 | об MTL 45 | 6. src/Protocol{/Wire}.hs - разбор протоколов, парсеры и все дела 46 | 7. src/Protocol/{Replies,Errors}.hs - специальные сообщения 47 | 8. src/Protocol/Types.hs - типы в irc 48 | 9. src/Uni.hs - просто файл `^_^` 49 | 50 | Я постараюсь не повторяться про отдельные вещи, поэтому при другой 51 | последовательности просмотра может быть не все понятно, так же я 52 | постараюсь ссылаться на применения одного места в другое. Но не обессудьте, 53 | если у меня будут получаться бесконечные или висящие ссылки. 54 | 55 | Так же я поздно заметил, что в irc text oriented протокол, чтобы 56 | приятно было работать в plain c, это можно было использовать и 57 | убрать часть вещей, например, можно было бы исключить Protocol.Message 58 | в виде большой ADT. 59 | 60 | Ещё я не описал работу Uni, там есть интересные вещи, как типы 61 | генерируют код, если вопросы будут, то я добавлю ответы в следующих 62 | коммитах 63 | 64 | Что и Как контрибьютить: 65 | 66 | 1. Код написан за 1 вечер + часть дня на комментарии и не идеален, 67 | так что все исправления стиля и т.п. допускаются, и я буду рад. 68 | 69 | 2. Более хорошее использование либ или другие либы: stm-conduit, 70 | streaming, megaparsec, len 71 | 72 | 2. Если вдруг что-то непонятно, или есть вопросы, то issues и 73 | комментарии приветствуются 74 | 75 | Спасибо, и успешного программирования, проектирования и тестированя! 76 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Main where 5 | 6 | import Client 7 | import Data.ByteString.Char8 (ByteString) 8 | import Data.Conduit.Network 9 | import Data.Monoid ((<>)) 10 | import Options.Applicative 11 | 12 | -- | Server configuration 13 | data Config = Config 14 | { cfgPort :: !Int 15 | , cfgHost :: !ByteString 16 | } 17 | 18 | -- | Command line parser 19 | irc :: Parser Config 20 | irc = Config <$> option auto 21 | ( long "port" 22 | <> metavar "PORT" 23 | <> short 'p' 24 | <> value 9999 25 | <> help "Application port") 26 | <*> option auto 27 | ( long "host" 28 | <> short 'h' 29 | <> metavar "HOST" 30 | <> value "localhost" 31 | <> help "Application host") 32 | 33 | main :: IO () 34 | main = execParser opts >>= run where 35 | run :: Config -> IO () 36 | run (Config port host) = client $ clientSettings port host 37 | opts = info (irc <**> helper) 38 | (fullDesc 39 | <> progDesc "simple irc server" 40 | <> header "irc - is a nice thing") 41 | -------------------------------------------------------------------------------- /app/server.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | -- Все необходимые импорты, список бывает достаточно большой ^_^ 4 | -- Тут вместо того, чтобы объяснять что и зачем нужно я сделаю 5 | -- явное импортирование 6 | import Data.Conduit.Network (serverSettings) 7 | import Data.Monoid ((<>)) 8 | import Data.String (fromString) 9 | -- Импортирование библиотеки для разбора опций командной строки, 10 | -- достаточно удобная, хотя некоторые предпочитают docopt, не знаю почему 11 | import Options.Applicative 12 | -- И загружаем нашу серверную логику из библиотеки. 13 | import Server 14 | 15 | -- | Тип описывающий конфиругацию исполняемого файла. 16 | -- 17 | -- INFO: Strict field. 18 | -- Смешной знак @!@ который тут есть говорит о тому, что поле должно быть 19 | -- строгим, (как в привычных ЯП). Грубо говоря Rule of thumb то, что в 20 | -- структурах которые не являются контрольными, т.е. не определяют control flow 21 | -- программы, все поля должны быть строгими. Контрольные структуры это не, по 22 | -- которым мы проходим при выполнении программы, можно сказать, что они как 23 | -- итераторы, но это не так, т.к. дерево - это не лучший итератор, но хорошая 24 | -- контрольная структура. 25 | data Config = Config 26 | { cfgPort :: !Int 27 | , cfgHost :: !String 28 | } 29 | 30 | -- | Функция которая декларативно описывает разбор конфигурации. 31 | -- 32 | -- INFO: Applicative. 33 | -- тут мы видим стандартный паттерн @f <$> a <*> b <*> c@ это применение 34 | -- аппликативного функтора, чтобы не вдаваться в подробности, опишу тут идею 35 | -- как это работает. Пусть у нас есть некоторый контекст, со своим состоянием, 36 | -- или особенностями (напр. список, парсер, билдер, IO, STM), и действия в 37 | -- этом контексте @a,b,c@. Тогда мы можем применить чистую функцию к результатам 38 | -- этих действией. Т.е. функция 'Config' это @Config :: Int -> String -> Config@, 39 | -- мы можем применить её к операциям @a :: Parser Int@ и @b :: Parser String@ и 40 | -- получить @Parser Config@. Т.о. собрать из блоков целое. В этом проекте такое 41 | -- будет употребяться повсеместно, так что стоит привыкнуть. 42 | -- 43 | -- Аналогия из "обычного языка": 44 | -- 45 | -- @ 46 | -- config = new Parser().function(Config).add(a).add(b).apply(); 47 | -- @ 48 | -- 49 | -- INFO: Monoid 50 | -- @(<>) :: a -> a -> a@ - позволяет собирать из 2ух структур более полную, 51 | -- для неё должны выполняться хорошие математические законы, позволяющие оптимизации. 52 | -- Часто используется для построения новой структуры. 53 | -- 54 | -- Аналогия из "обычного языка": 55 | -- 56 | -- @ 57 | -- value = new Builder().long("port").metavar("PORT").short('p').value(9999).build(); 58 | -- @ 59 | -- 60 | irc :: Parser Config 61 | irc = Config <$> option auto -- Получить значение типа который вывелся 62 | ( long "port" -- опция @--port@ 63 | <> metavar "PORT" -- подстановка при выводе help 64 | <> short 'p' -- опция @-p@ 65 | <> value 9999 -- значение по умолчанию 66 | <> help "Application port") -- строка подсказки 67 | <*> strOption 68 | ( long "host" 69 | <> short 'h' 70 | <> metavar "HOST" 71 | <> value "localhost" 72 | <> help "Application host") 73 | 74 | main :: IO () 75 | main = execParser opts >>= run where -- запустить парсер и передать полученное 76 | -- значение в программу, или вывести помощь 77 | -- или сообещение об ошибке пользователю 78 | run :: Config -> IO () 79 | run (Config port host) = 80 | server $ serverSettings port (fromString host) -- запускаем наш сервер 81 | -- формирование красивых сообщений для --help. 82 | opts = info (irc <**> helper) 83 | (fullDesc 84 | <> progDesc "simple irc server" 85 | <> header "irc - is a nice thing") 86 | -------------------------------------------------------------------------------- /cabal.project.freeze: -------------------------------------------------------------------------------- 1 | constraints: Cabal ==2.0.1.0, 2 | StateVar ==1.1.0.4, 3 | adjunctions ==4.4, 4 | ansi-terminal ==0.8.0.2, 5 | ansi-terminal -example, 6 | ansi-wl-pprint ==0.6.8.2, 7 | ansi-wl-pprint -example, 8 | array ==0.5.2.0, 9 | async ==2.2.1, 10 | async -bench, 11 | attoparsec ==0.13.2.2, 12 | attoparsec -developer, 13 | base ==4.10.1.0, 14 | base-orphans ==0.7, 15 | bifunctors ==5.5.2, 16 | bifunctors +tagged +semigroups, 17 | binary ==0.8.5.1, 18 | bytestring ==0.10.8.2, 19 | cabal-doctest ==1.0.6, 20 | call-stack ==0.1.0, 21 | clock ==0.7.2, 22 | clock -llvm, 23 | colour ==2.3.4, 24 | comonad ==5.0.3, 25 | comonad +test-doctests +distributive +contravariant +containers, 26 | conduit ==1.3.0.2, 27 | conduit-extra ==1.3.0, 28 | containers ==0.5.10.2, 29 | contravariant ==1.4.1, 30 | contravariant +tagged +statevar +semigroups -safe, 31 | deepseq ==1.4.3.0, 32 | directory ==1.3.0.2, 33 | distributive ==0.5.3, 34 | distributive +tagged +semigroups, 35 | exceptions ==0.10.0, 36 | fail ==4.9.0.0, 37 | filepath ==1.4.1.2, 38 | free ==5.0.1, 39 | ghc-boot-th ==8.2.2, 40 | ghc-prim ==0.5.1.1, 41 | hashable ==1.2.7.0, 42 | hashable -sse41 +sse2 +integer-gmp -examples, 43 | integer-gmp ==1.0.1.0, 44 | integer-logarithms ==1.0.2.1, 45 | integer-logarithms +integer-gmp -check-bounds, 46 | kan-extensions ==5.1, 47 | lens ==4.16, 48 | lens +trustworthy +test-templates +test-properties +test-hunit +test-doctests -safe -old-inline-pragmas -j +inlining -dump-splices -benchmark-uniplate, 49 | logict ==0.6.0.2, 50 | mono-traversable ==1.0.8.1, 51 | mtl ==2.2.2, 52 | network ==2.6.3.4, 53 | optparse-applicative ==0.14.2.0, 54 | parallel ==3.2.1.1, 55 | pretty ==1.1.3.3, 56 | primitive ==0.6.3.0, 57 | process ==1.6.1.0, 58 | profunctors ==5.2.2, 59 | random ==1.1, 60 | reflection ==2.1.3, 61 | reflection +template-haskell -slow, 62 | resourcet ==1.2.0, 63 | rts ==1.0, 64 | scientific ==0.3.5.3, 65 | scientific -integer-simple -bytestring-builder, 66 | semigroupoids ==5.2.2, 67 | semigroupoids +unordered-containers +tagged +doctests +distributive +contravariant +containers +comonad, 68 | semigroups ==0.18.4, 69 | semigroups +unordered-containers +transformers +text +tagged +hashable +deepseq +containers -bytestring-builder +bytestring +binary, 70 | smallcheck ==1.1.3.1, 71 | split ==0.2.3.3, 72 | stm ==2.4.5.0, 73 | streaming-commons ==0.2.0.0, 74 | streaming-commons -use-bytestring-builder, 75 | tagged ==0.8.5, 76 | tagged +transformers +deepseq, 77 | tasty ==1.0.1.1, 78 | tasty +clock, 79 | tasty-hunit ==0.10.0.1, 80 | tasty-smallcheck ==0.8.1, 81 | template-haskell ==2.12.0.0, 82 | text ==1.2.3.0, 83 | text -integer-simple -developer -bytestring-builder, 84 | th-abstraction ==0.2.6.0, 85 | time ==1.8.0.2, 86 | transformers ==0.5.5.0, 87 | transformers-base ==0.4.4, 88 | transformers-base +orphaninstances, 89 | transformers-compat ==0.6.0.6, 90 | transformers-compat -two -three +mtl +generic-deriving -four -five, 91 | typed-process ==0.2.2.0, 92 | unbounded-delays ==0.1.1.0, 93 | unix ==2.7.2.2, 94 | unliftio-core ==0.1.1.0, 95 | unordered-containers ==0.2.9.0, 96 | unordered-containers -debug, 97 | vector ==0.12.0.1, 98 | vector -wall -unsafechecks -internalchecks +boundschecks, 99 | vector-algorithms ==0.7.0.1, 100 | vector-algorithms -unsafechecks +properties -internalchecks +boundschecks -bench, 101 | void ==0.7.2, 102 | void -safe, 103 | zlib ==0.6.2, 104 | zlib -pkg-config -non-blocking-ffi 105 | -------------------------------------------------------------------------------- /irc-simple.cabal: -------------------------------------------------------------------------------- 1 | name: irc-simple 2 | version: 0.1.0.0 3 | synopsis: Simple IRC-like server 4 | description: Simple IRC like server for learning purposes, this server 5 | does not solve all the problems and does not respect RFC-2813. 6 | This is done for the purpose of the simplicity and in addition 7 | it can be used in order to introduce additional functionality and 8 | learn and show how is it possible to refactor Haskell code. 9 | . 10 | On it's own this is only a learning project but it's possible to 11 | convert this code to either full featured irc server or to some 12 | other *non-persistent* pub-sub service. 13 | license: BSD3 14 | license-file: LICENSE 15 | author: Alexander Vershilov 16 | maintainer: alexander.vershilov@gmail.com 17 | -- copyright: 18 | category: Network 19 | build-type: Simple 20 | extra-source-files: ChangeLog.md 21 | 22 | cabal-version: >=2.0 23 | 24 | 25 | library 26 | exposed-modules: Client 27 | Server 28 | Server.Internal 29 | Server.Handler 30 | Server.Channel 31 | Server.User 32 | Protocol 33 | Protocol.Errors 34 | Protocol.Types 35 | Protocol.Replies 36 | Protocol.Wire 37 | Uni 38 | build-depends: base, 39 | async, 40 | attoparsec, 41 | bytestring, 42 | conduit, 43 | conduit-extra, 44 | containers, 45 | exceptions, 46 | resourcet, 47 | stm, 48 | lens, 49 | mtl, 50 | smallcheck, 51 | text, 52 | transformers, 53 | transformers-base 54 | options-ghc: -Wall -Werror 55 | hs-source-dirs: src 56 | default-language: Haskell2010 57 | 58 | executable server 59 | main-is: server.hs 60 | build-depends: base, 61 | irc-simple, 62 | bytestring, 63 | conduit-extra, 64 | optparse-applicative 65 | options-ghc: -Wall -Werror 66 | hs-source-dirs: app 67 | default-language: Haskell2010 68 | 69 | executable client 70 | main-is: client.hs 71 | build-depends: base, 72 | irc-simple, 73 | bytestring, 74 | conduit-extra, 75 | optparse-applicative 76 | hs-source-dirs: app 77 | options-ghc: -Wall -Werror 78 | default-language: Haskell2010 79 | 80 | test-suite unit 81 | type: exitcode-stdio-1.0 82 | default-language: Haskell2010 83 | hs-source-dirs: tests 84 | main-is: unit.hs 85 | other-modules: Test.Protocol.Parser 86 | build-depends: base, 87 | irc-simple, 88 | attoparsec, 89 | lens, 90 | smallcheck, 91 | tasty, 92 | tasty-hunit, 93 | tasty-smallcheck, 94 | text 95 | options-ghc: -Wall -Werror 96 | default-language: Haskell2010 97 | 98 | -------------------------------------------------------------------------------- /src/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Client 3 | ( client 4 | ) where 5 | 6 | 7 | import Control.Monad.IO.Class 8 | import Control.Concurrent.Async 9 | import Control.Concurrent.STM 10 | import Data.Monoid 11 | import Data.Text (Text) 12 | import qualified Data.Text as Text 13 | import Conduit 14 | import Data.Conduit.Combinators 15 | import qualified Data.Conduit.Text as CT 16 | import Data.Conduit.Network 17 | 18 | client :: ClientSettings -> IO () 19 | client settings = do 20 | q <- newTQueueIO 21 | _ <- async $ runTCPClient settings $ \ad -> 22 | race_ (runConduit 23 | $ repeatM (atomically $ readTQueue q) 24 | .| CT.encode CT.utf8 25 | .| appSink ad) 26 | (runConduit 27 | $ appSource ad 28 | .| CT.decode CT.utf8 29 | .| Data.Conduit.Combinators.print) 30 | loop q 31 | where 32 | loop :: TQueue Text -> IO () 33 | loop q = do 34 | input <- getLine 35 | case input of 36 | "" -> return () 37 | "quit" -> return () 38 | s -> do 39 | let t = Text.pack s <> "\r\n" 40 | liftIO $ Prelude.print t 41 | liftIO $ atomically $ writeTQueue q t 42 | loop q 43 | -------------------------------------------------------------------------------- /src/Protocol.hs: -------------------------------------------------------------------------------- 1 | -- После того как я написал код, я начал с этого, я понял 2 | -- что мне очень не нравится это файл и я бы все переделал. 3 | -- 4 | -- Отображать все сообщения для ADT та ещё задача тем более, 5 | -- что их будет много. Даже если это и нормально, то парсер 6 | -- написан не самым эффективным образом. Поэтому лучше как-то 7 | -- объединить парсер с case split в коде Server.hs. 8 | -- 9 | -- Впрочем это работает и можно обосновать. 10 | {-# LANGUAGE OverloadedStrings #-} 11 | module Protocol 12 | ( Message(..) 13 | , T.Nickname(..) 14 | , T.Channel(..) 15 | , T.MsgTo(..) 16 | , protocol 17 | ) where 18 | 19 | import Control.Lens 20 | import Control.Monad.Catch 21 | import qualified Protocol.Wire as Wire 22 | import Protocol.Types (Protocol(..), params, trailing, mkTextCommand) 23 | import qualified Protocol.Types as T 24 | import Data.Conduit 25 | import Data.ByteString (ByteString) 26 | import Data.Text (Text) 27 | import Data.Foldable 28 | import qualified Data.Conduit.List as CL 29 | 30 | -- | Типизированное сообщение, поддерживаемое сервером. Если 31 | -- у нас какие-то проблемы с контентом сообщения то мы это 32 | -- увидим. 33 | data Message 34 | = -- | присоединиться к каналу 35 | Join T.Channel 36 | -- | Уйти с канала 37 | | Part T.Channel (Maybe Text) 38 | -- | Послать сообщение 39 | | PrivMsg T.MsgTarget Text 40 | -- | Сменить ник 41 | | Nick T.Nickname 42 | deriving (Show) 43 | 44 | -- | Конвертация в нетипизированное сообщение 45 | instance Wire.IsMessage Message where 46 | toMessage (Join chan) = 47 | mkTextCommand "JOIN" & params .~ [T.toParam chan] 48 | toMessage (Part chan reason) = 49 | mkTextCommand "PART" & params .~ [T.toParam chan] 50 | & trailing .~ reason 51 | toMessage (PrivMsg trgt text) = 52 | mkTextCommand "PRIVMSG" & params .~ [T.toParam trgt] 53 | & trailing ?~ text 54 | toMessage (Nick nick) = 55 | mkTextCommand "NICK" & params .~ [T.toParam nick] 56 | 57 | -- Протокол, см. Protocol.Ty[es 58 | protocol :: MonadThrow m => Protocol m Wire.Message Message ByteString 59 | protocol = Protocol 60 | { encodeStream = encodeStream Wire.protocol 61 | , decodeStream = decodeStream Wire.protocol 62 | .| CL.mapMaybe parseCommand 63 | } 64 | 65 | -- | Разбор сообщений 66 | -- 67 | -- XXX: тут можно использовать either и накапливать и выводить ошибки, так 68 | -- же поддерживать warnings, но мне лень 69 | parseCommand :: Wire.Message -> Maybe Message 70 | parseCommand msg = asum 71 | [ do Wire.Message Nothing (Wire.TextCommand "JOIN") [mchannel] _ <- pure msg 72 | chan <- Wire.parseParam Wire.channel mchannel 73 | pure $ Join chan 74 | , do Wire.Message Nothing (Wire.TextCommand "PART") [mchannel] reason <- pure msg 75 | chan <- Wire.parseParam Wire.channel mchannel 76 | pure $ Part chan reason 77 | , do Wire.Message Nothing (Wire.TextCommand "PRIVMSG") [mrecipient] (Just text) <- pure msg 78 | target <- Wire.parseParam Wire.msgtarget mrecipient 79 | pure $ PrivMsg target text 80 | , do Wire.Message Nothing (Wire.TextCommand "NICK") [muser] Nothing <- pure msg 81 | user <- Wire.parseParam Wire.nickname muser 82 | pure $ Nick user 83 | ] 84 | -------------------------------------------------------------------------------- /src/Protocol/Errors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyCase #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | module Protocol.Errors 9 | ( NickNameInUse(..) 10 | , NoSuchNick(..) 11 | , NoSuchChannel(..) 12 | , NotOnChannel(..) 13 | , UserOnChannel(..) 14 | , IsCodeError(..) 15 | , errorToWire 16 | ) where 17 | 18 | import Control.Lens 19 | import Protocol.Types 20 | import Uni 21 | 22 | class IsCodeError a where 23 | code :: a -> Code 24 | populate :: a -> Message -> Message 25 | 26 | errorToWire :: IsCodeError a => a -> Message 27 | errorToWire a = populate a $ mkCodeCommand (code a) 28 | 29 | instance {-# OVERLAPS #-} (IsCodeError e) => IsCodeError (Uni '[e]) where 30 | code (This e) = code e 31 | code (That v) = case v of {} 32 | populate (This e) = populate e 33 | populate (That v) = case v of {} 34 | 35 | instance {-# OVERLAPPABLE #-} (IsCodeError e, IsCodeError (Uni es)) => IsCodeError (Uni (e ': es)) where 36 | code (This e) = code e 37 | code (That es) = code es 38 | populate (This e) = populate e 39 | populate (That es) = populate es 40 | 41 | instance (IsCodeError a, IsCodeError b) => IsCodeError (Either a b) where 42 | code (Left a) = code a 43 | code (Right b) = code b 44 | populate (Left a) = populate a 45 | populate (Right b) = populate b 46 | 47 | -- | @401 ERR_NOSUCHNICK " :No such server"@ 48 | newtype NoSuchNick = NoSuchNick Nickname 49 | instance IsCodeError NoSuchNick where 50 | code _ = Code 4 0 1 51 | populate (NoSuchNick nick) msg 52 | = msg & params .~ [toParam nick] 53 | & trailing ?~ "No such nick/channel" 54 | 55 | -- 402 ERR_NOSUCHSERVER " :No such server" 56 | 57 | -- | @403 ERR_NOSUCHCHANNEL" :No such channel"@ 58 | newtype NoSuchChannel = NoSuchChannel Channel 59 | instance IsCodeError NoSuchChannel where 60 | code _ = Code 4 0 3 61 | populate (NoSuchChannel chan) msg 62 | = msg & params .~ [toParam chan] 63 | & trailing ?~ "No such channel" 64 | 65 | -- | @404 ERR_CANNOTSENDTOCHAN" :Cannot send to channel"@ 66 | newtype CanNotSendToChan = CanNotSendToChan Channel 67 | instance IsCodeError CanNotSendToChan where 68 | code _ = Code 4 0 4 69 | populate (CanNotSendToChan chan) msg 70 | = msg & params .~ [toParam chan] 71 | & trailing ?~ "Cannot send to channel" 72 | 73 | -- 405 ERR_TOOMANYCHANNELS" :You have joined too many channels" 74 | -- 406 ERR_WASNOSUCHNICK" :There was no such nickname" 75 | -- 407 ERR_TOOMANYTARGETS" : recipients. " 76 | -- 408 ERR_NOSUCHSERVICE" :No such service" 77 | -- 409 ERR_NOORIGIN":No origin specified" 78 | -- 411 ERR_NORECIPIENT":No recipient given ()" 79 | -- 412 ERR_NOTEXTTOSEND":No text to send" 80 | -- 413 ERR_NOTOPLEVEL" :No toplevel domain specified" 81 | -- 414 ERR_WILDTOPLEVEL" :Wildcard in toplevel domain" 82 | -- 415 ERR_BADMASK" :Bad Server/host mask" 83 | -- 421 ERR_UNKNOWNCOMMAND" :Unknown command" 84 | -- 422 ERR_NOMOTD":MOTD File is missing" 85 | -- 423 ERR_NOADMININFO" :No administrative info available" 86 | -- 424 ERR_FILEERROR":File error doing on " 87 | -- 431 ERR_NONICKNAMEGIVEN":No nickname given" 88 | -- 432 ERR_ERRONEUSNICKNAME" :Erroneous nickname" 89 | 90 | -- | @433 ERR_NICKNAMEINUSE" :Nickname is already in use"@ 91 | newtype NickNameInUse = NickNameInUse Nickname 92 | instance IsCodeError NickNameInUse where 93 | code _ = Code 4 3 3 94 | populate (NickNameInUse nick) msg 95 | = msg & params .~ [toParam nick] 96 | & trailing ?~ "Nickname already is use" 97 | -- 436 ERR_NICKCOLLISION" :Nickname collision KILL from @" 98 | -- 437 ERR_UNAVAILRESOURCE" :Nick/channel is temporarily unavailable" 99 | -- 441 ERR_USERNOTINCHANNEL" :They aren't on that channel" 100 | 101 | -- | @442 ERR_NOTONCHANNEL" :You're not on that channel"@ 102 | newtype NotOnChannel = NotOnChannel Channel 103 | instance IsCodeError NotOnChannel where 104 | code _ = Code 4 4 2 105 | populate (NotOnChannel chan) msg 106 | = msg & params .~ [toParam chan] 107 | & trailing ?~ "You're not on that channel" 108 | 109 | -- | @443 ERR_USERONCHANNEL" :is already on channel"@ 110 | data UserOnChannel = UserOnChannel !Nickname !Channel 111 | instance IsCodeError UserOnChannel where 112 | code _ = Code 4 4 3 113 | populate (UserOnChannel nick chan) msg 114 | = msg & params .~ [toParam nick, toParam chan] 115 | & trailing ?~ "is already on channel" 116 | 117 | -- 444 ERR_NOLOGIN" :User not logged in" 118 | -- 445 ERR_SUMMONDISABLED":SUMMON has been disabled" 119 | -- 446 ERR_USERSDISABLED":USERS has been disabled" 120 | -- 451 ERR_NOTREGISTERED":You have not registered" 121 | -- 461 ERR_NEEDMOREPARAMS" :Not enough parameters" 122 | -- 462 ERR_ALREADYREGISTRED":Unauthorized command (already registered)" 123 | -- 463 ERR_NOPERMFORHOST":Your host isn't among the privileged" 124 | -- 464 ERR_PASSWDMISMATCH":Password incorrect" 125 | -- 465 ERR_YOUREBANNEDCREEP":You are banned from this server" 126 | -- 466 ERR_YOUWILLBEBANNED 127 | -- 467 ERR_KEYSET" :Channel key already set" 128 | -- 471 ERR_CHANNELISFULL" :Cannot join channel (+l)" 129 | -- 472 ERR_UNKNOWNMODE" :is unknown mode char to me for " 130 | -- 473 ERR_INVITEONLYCHAN" :Cannot join channel (+i)" 131 | -- 474 ERR_BANNEDFROMCHAN" :Cannot join channel (+b)" 132 | -- 475 ERR_BADCHANNELKEY" :Cannot join channel (+k)" 133 | -- 476 ERR_BADCHANMASK" :Bad Channel Mask" 134 | -- 477 ERR_NOCHANMODES" :Channel doesn't support modes" 135 | -- 478 ERR_BANLISTFULL" :Channel list is full" 136 | -- 481 ERR_NOPRIVILEGES":Permission Denied- You're not an IRC operator" 137 | -- 482 ERR_CHANOPRIVSNEEDED" :You're not channel operator" 138 | -- 483 ERR_CANTKILLSERVER":You can't kill a server!" 139 | -- 484 ERR_RESTRICTED":Your connection is restricted!" 140 | -- 485 ERR_UNIQOPPRIVSNEEDED":You're not the original channel operator" 141 | -- 491 ERR_NOOPERHOST":No O-lines for your host" 142 | -- 501 ERR_UMODEUNKNOWNFLAG":Unknown MODE flag" 143 | -- 502 ERR_USERSDONTMATCH":Cannot change mode for other users" 144 | -------------------------------------------------------------------------------- /src/Protocol/Parser.hs: -------------------------------------------------------------------------------- 1 | module Protocol.Parser 2 | ( 3 | ) where 4 | -------------------------------------------------------------------------------- /src/Protocol/Replies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Protocol.Replies 3 | ( ReplyTopic(..) 4 | , NamReply(..) 5 | ) where 6 | 7 | import Control.Lens 8 | import Data.Coerce 9 | import Data.Text (Text) 10 | import qualified Data.Text as Text 11 | import Data.Set (Set) 12 | import qualified Data.Set as Set 13 | import Protocol.Types 14 | 15 | data ReplyTopic = ReplyTopic !Channel !Text 16 | 17 | instance IsMessage ReplyTopic where 18 | toMessage (ReplyTopic chan topic) = mkCodeCommand (Code 3 3 2) 19 | & params .~ [toParam chan] 20 | & trailing ?~ topic 21 | 22 | data NamReply = NamReply !Channel !(Set Nickname) 23 | 24 | instance IsMessage NamReply where 25 | toMessage (NamReply chan nicks) = mkCodeCommand (Code 3 5 3) 26 | & params .~ [toParam chan] 27 | & trailing ?~ Text.intercalate " " (coerce Set.toAscList nicks) 28 | -------------------------------------------------------------------------------- /src/Protocol/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | module Protocol.Types 6 | ( Protocol(..) 7 | , Protocol' 8 | -- * Message 9 | , Message(..) 10 | , IsMessage(..) 11 | , IsParam(..) 12 | , mkCodeCommand 13 | , mkTextCommand 14 | , prefix 15 | , command 16 | , params 17 | , trailing 18 | , Command(..) 19 | , Code(..) 20 | , Nickname(..) 21 | , Channel(..) 22 | , Param(..) 23 | , Prefix(..) 24 | , MsgTarget(..) 25 | , MsgTo(..) 26 | ) where 27 | 28 | import Conduit 29 | import Control.Lens 30 | import Data.Coerce 31 | import Data.List.NonEmpty (NonEmpty(..)) 32 | import qualified Data.List.NonEmpty as NE 33 | import Data.Monoid 34 | import Data.String 35 | import Data.Text (Text) 36 | import qualified Data.Text as Text 37 | import GHC.Generics 38 | 39 | type Protocol' m t o = Protocol m t t o 40 | 41 | -- протокол который описывает как преобразуются сообщения 42 | -- m - контекст в котором работаем 43 | -- s - внутренний тип ответов (клиенту) 44 | -- t - внутренний тип запросов (от клиента) 45 | -- o - тип общения по проводу Text/ByteString 46 | data Protocol m s t o = Protocol 47 | { encodeStream :: ConduitT s o m () 48 | , decodeStream :: ConduitT o t m () 49 | } 50 | 51 | -- | Обобщенный тип сообщения с соотвествии с RFC. 52 | data Message = Message 53 | { _prefix :: !(Maybe Prefix) 54 | , _command :: !Command 55 | , _params :: ![Param] 56 | , _trailing :: !(Maybe Text) 57 | } deriving (Show, Eq, Generic) 58 | 59 | 60 | mkCodeCommand :: Code -> Message 61 | mkCodeCommand code = Message Nothing (IntCommand code) [] Nothing 62 | 63 | mkTextCommand :: Text -> Message 64 | mkTextCommand cmd = Message Nothing (TextCommand cmd) [] Nothing 65 | 66 | -- | Код команды 67 | data Code = Code !Int !Int !Int deriving (Eq, Show, Generic) 68 | 69 | -- | Команда 70 | data Command 71 | = TextCommand {-# UNPACK #-} !Text 72 | | IntCommand {-# UNPACK #-} !Code 73 | deriving (Show, Eq, Generic) 74 | 75 | -- | Имя пользователя 76 | newtype Nickname = Nickname Text deriving (Show, Eq, Ord, IsString) 77 | 78 | -- | Имя канала. 79 | newtype Channel = Channel Text deriving (Show, Eq, Ord, IsString) 80 | 81 | -- | Источник сообщения 82 | newtype Prefix = Prefix Nickname deriving (Show, Eq, IsString, Generic) 83 | 84 | 85 | instance IsString Command where 86 | fromString = TextCommand . Text.pack 87 | 88 | -- | Параметр команды 89 | newtype Param = Param Text deriving (Show, Eq, IsString, Generic) 90 | 91 | 92 | -- | Список адресатов 93 | newtype MsgTarget = MsgTarget (NonEmpty MsgTo) deriving (Show, Eq) 94 | 95 | -- | Адресат сообщения 96 | data MsgTo 97 | = MsgToChannel !Channel 98 | | MsgToUser !Nickname 99 | deriving (Eq, Show) 100 | 101 | -- | Интерфейс описывающий, что данный тип может быть 102 | -- преобразован в сообщение 103 | class IsMessage a where toMessage :: a -> Message 104 | 105 | instance IsMessage Message where toMessage = id 106 | 107 | instance (IsMessage a, IsMessage b) => IsMessage (Either a b) where 108 | toMessage (Left a) = toMessage a 109 | toMessage (Right b) = toMessage b 110 | 111 | 112 | class IsParam a where 113 | toParam :: a -> Param 114 | 115 | instance IsParam Param where 116 | toParam = id 117 | 118 | instance IsParam Nickname where 119 | toParam = coerce 120 | 121 | instance IsParam a => IsParam [a] where 122 | toParam = coerce . Text.intercalate "," . coerce . map toParam 123 | 124 | instance IsParam MsgTarget where 125 | toParam (MsgTarget ne) = toParam $ NE.toList ne 126 | 127 | instance IsParam MsgTo where 128 | toParam (MsgToChannel chan) = toParam chan 129 | toParam (MsgToUser user) = toParam user 130 | 131 | instance IsParam Channel where 132 | toParam (Channel chan) = Param $ "#" <> coerce chan 133 | 134 | 135 | 136 | 137 | makeLenses ''Message 138 | 139 | -------------------------------------------------------------------------------- /src/Protocol/Wire.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | -- | Обработка сырого протокола. 3 | module Protocol.Wire 4 | ( -- * Типы 5 | Message(..) 6 | , MsgTarget(..) 7 | , MsgTo(..) 8 | , Command(..) 9 | , Nickname(..) 10 | , Channel(..) 11 | , Param(..) 12 | , Prefix(..) 13 | , Code(..) 14 | , IsMessage(..) 15 | , IsParam(..) 16 | -- * Конвертация в текстовое сообщение 17 | , protocol 18 | , toWire 19 | -- $bnf 20 | , message 21 | , msgtarget 22 | , nickname 23 | , channel 24 | , parseParam 25 | , trailing 26 | , prefix 27 | , command 28 | , middle 29 | ) where 30 | 31 | import Control.Applicative 32 | import Control.Monad.Catch 33 | import Data.ByteString (ByteString) 34 | import Data.Char (digitToInt, isLetter, isDigit) 35 | import Data.Text (Text) 36 | import qualified Data.List.NonEmpty as NE 37 | import Data.Monoid 38 | import Data.Text.Internal.Builder as Builder 39 | import Data.Text.Internal.Builder.Functions (i2d) 40 | import qualified Data.Text as Text 41 | import qualified Data.Text.Lazy as Text.Lazy 42 | import Data.Attoparsec.Text as Parser 43 | import Data.Foldable 44 | import Data.Coerce 45 | import Protocol.Types hiding (prefix, command, trailing) 46 | import Data.Conduit 47 | import Data.Conduit.Attoparsec 48 | import qualified Data.Conduit.Combinators as CC 49 | import qualified Data.Conduit.List as CL 50 | import qualified Data.Conduit.Text as CT 51 | 52 | -- Создание из сообщения его представление в проводе, аналогично Builder 53 | -- в привычных языках. А builder ~ Monoid 54 | toWire :: Message -> Builder 55 | toWire (Message prefix' cmd params' trail) = mconcat 56 | [ case prefix' of 57 | Nothing -> mempty 58 | Just (Prefix (Nickname nick)) -> 59 | Builder.singleton ':' <> Builder.fromText nick <> Builder.singleton ' ' 60 | , case cmd of 61 | TextCommand t -> Builder.fromText t 62 | IntCommand (Code a b c) -> 63 | Builder.singleton (i2d a) 64 | <> Builder.singleton (i2d b) 65 | <> Builder.singleton (i2d c) 66 | , case params' of 67 | [] -> mempty 68 | _ -> singleton ' ' <> Builder.fromText (Text.intercalate " " $ coerce params') 69 | , case trail of 70 | Nothing -> mempty 71 | Just s -> Builder.singleton ' ' 72 | <> Builder.singleton ':' 73 | <> Builder.fromText s 74 | , singleton '\r' 75 | , singleton '\n' 76 | ] 77 | 78 | -- | разбор параметров 79 | parseParam :: Parser a -> Param -> Maybe a 80 | parseParam p (Param t) = case parseOnly p t of 81 | Left _err -> Nothing 82 | Right x -> pure x 83 | 84 | -- / Протокол 85 | protocol :: MonadThrow m => Protocol' m Message ByteString 86 | protocol = Protocol 87 | { decodeStream = CT.decode CT.utf8 --- декодируем текст из байтов 88 | .| conduitParser message -- запускаем парсер 89 | .| CL.map snd -- убираем информацию о позициях в потоке 90 | , encodeStream = CL.map (Text.Lazy.toChunks . Builder.toLazyText . toWire) -- получаем текст из билдера 91 | .| CC.concat -- отправляем все чанками хорошего размера 92 | .| CT.encode CT.utf8 -- кодируем текст в байты 93 | } 94 | 95 | -- а дальше используем парсер он маппится в функции 1 в 1, буков там много 96 | -- но если каждый раз возвращаться к BNF то все должно быть ясно. 97 | -- 98 | -- $bnf 99 | -- 100 | -- BNF протокола: 101 | -- 102 | -- Упрощения: 103 | -- 1. часть протокола упрощена (отмечено (!)) 104 | -- 2. не делается проверка на наличие NULL в сообщениях 105 | -- 3. не введено ограничение на размеры параметров и строк, которые 106 | -- присутсвуют в протоколе 107 | -- @ 108 | -- message ::= [ ":" prefix SPACE ] command [params] clrf 109 | -- prefix ::= nickname -- (!) 110 | -- command ::= 1*letter | 3 digit 111 | -- params ::= *(SPACE middle) [SPACE ":" trailing] 112 | -- middle ::= nospcrlf * (":" nospcrlfcl) 113 | -- trailing ::= *(":" | " " | nospcrlcfl) 114 | -- space ::= ' ' 115 | -- crlf ::= '\r\n' 116 | -- 117 | -- nickname ::= (1*letter | special) *(letter | digit | special | "-") 118 | -- msgtarget ::= msgto *("," msgto) 119 | -- msgto ::= channel | user -- (!) 120 | -- channel ::= ( "#" ) chanstring -- (!) 121 | -- chanstring ::= * ; Any except NUL, BELL, CR, LF, " ", ",", ":" 122 | -- special ::= * ; "[", "]", "\", "`", "_", "^", "{", "|", "}" 123 | -- @ 124 | 125 | -- | Парсер сообщения 126 | message :: Parser Message 127 | message = convert 128 | <$> optional (char ':' *> prefix <* char ' ') 129 | <*> command 130 | <*> (optional ((,) <$> many1 (char ' ' *> (Param <$> middle)) 131 | <*> optional (space *> char ':' *> trailing))) 132 | <* char '\r' 133 | <* char '\n' 134 | where 135 | convert mprefix cmd Nothing = Message mprefix cmd [] Nothing 136 | convert mprefix cmd (Just (x,mt)) = Message mprefix cmd x mt 137 | 138 | -- | Парсер префикса 139 | prefix :: Parser Prefix 140 | prefix = Prefix <$> nickname 141 | 142 | -- | Парсер ника 143 | nickname :: Parser Nickname 144 | nickname = fmap Nickname $ 145 | Text.cons <$> (special <|> letter) 146 | <*> Parser.takeWhile (getAny . foldMap (fmap Any) [isLetter, isDigit, isSpecial]) 147 | 148 | -- | Парсер канала 149 | channel :: Parser Channel 150 | channel = Channel <$> (char '#' *> Parser.takeWhile chanstring) 151 | 152 | -- | Команда 153 | command :: Parser Command 154 | command = asum 155 | [ fmap TextCommand $ Text.cons <$> letter <*> Parser.takeWhile isLetter 156 | , fmap IntCommand $ Code <$> (digitToInt <$> digit) 157 | <*> (digitToInt <$> digit) 158 | <*> (digitToInt <$> digit) 159 | ] 160 | 161 | -- | Собираем все выражения для, в которых нету контрольных символов. 162 | middle :: Parser Text 163 | middle = takeWhile1 nospcrlf 164 | 165 | special :: Parser Char 166 | special = satisfy isSpecial 167 | 168 | -- | Собираем все сообщение до конца. 169 | trailing :: Parser Text 170 | trailing = Parser.takeWhile (/= '\r') 171 | 172 | msgtarget :: Parser MsgTarget 173 | msgtarget = fmap MsgTarget $ (NE.:|) <$> msgto <*> sepBy msgto "," 174 | 175 | msgto :: Parser MsgTo 176 | msgto = asum [ MsgToChannel <$> channel 177 | , MsgToUser <$> nickname 178 | ] 179 | 180 | -- | Допустим ли символ при кодировании параметра 181 | nospcrlf :: Char -> Bool 182 | nospcrlf '\r' = False 183 | nospcrlf '\n' = False 184 | nospcrlf ' ' = False 185 | nospcrlf ':' = False 186 | nospcrlf '\0' = False 187 | nospcrlf _ = True 188 | 189 | -- | Допустим ли символ при кодировании канала 190 | chanstring :: Char -> Bool 191 | chanstring '\0' = False 192 | chanstring '\BEL' = False 193 | chanstring '\r' = False 194 | chanstring '\n' = False 195 | chanstring ' ' = False 196 | chanstring ',' = False 197 | chanstring ':' = False 198 | chanstring _ = True 199 | 200 | isSpecial :: Char -> Bool 201 | isSpecial '[' = True 202 | isSpecial ']' = True 203 | isSpecial '\\' = True 204 | isSpecial '_' = True 205 | isSpecial '`' = True 206 | isSpecial '^' = True 207 | isSpecial '{' = True 208 | isSpecial '}' = True 209 | isSpecial '|' = True 210 | isSpecial _ = False 211 | -------------------------------------------------------------------------------- /src/Server.hs: -------------------------------------------------------------------------------- 1 | -- Это уже интересная часть сервера, в этом файле мы описываем 2 | -- сам сервер и как он работает с внешним миром, эта часть примерно 3 | -- постоянная не зависимо от того, что же за реализацию мы засунем 4 | -- в сервер. Поехали! 5 | -- 6 | -- Сначала подключим расширения (их компилятор скажет когда подключить) 7 | -- вообще надо помнить, что Haskell это implementation defined язык и 8 | -- жизни вне GHC нету. Так что расширения это не какие-то плагины (которые есть) 9 | -- это вполне нормально 10 | {-# LANGUAGE FlexibleContexts #-} -- игнорируйте 11 | {-# LANGUAGE TypeApplications #-} -- применение типов, например, у вас есть 12 | -- функция @foo :: forall a . b -> a -> b@ 13 | -- и компилятор не может вывести тип @b@ 14 | -- из контекста, а мы можем сказать, 'foo @ A' 15 | -- и компилятор уже знает что это foo :: b -> A b 16 | -- тут это чисто для интереса, можно и обойтись 17 | {-# LANGUAGE DataKinds #-} -- тоже для интереса позволяет использовать конструкторы типов 18 | -- гетерогенного множества см Uni 19 | {-# LANGUAGE ScopedTypeVariables #-} 20 | {-# LANGUAGE ExplicitForAll #-} -- позволяет писать @foo :: forall a . a@ (вот это forall) 21 | {-# LANGUAGE LambdaCase #-} -- позволяет писать @foo >>= \case@ вместо @foo >>= \x -> case x of@ 22 | module Server 23 | ( server 24 | -- * Internal 25 | , asyncClient 26 | , clientConduit 27 | ) where 28 | 29 | import Conduit -- фреймворк позволяющий итеративную обработку данных 30 | import Control.Concurrent.Async -- библиотека для безопасной работы с потоками 31 | -- весьма неплохая и рекомендуется новичкам 32 | import Control.Concurrent.STM -- software transactional memory 33 | import Control.Monad (unless, join) 34 | import Control.Monad.Trans.Reader -- возможность таскать свой контекст 35 | import Control.Monad.Trans.Resource (ResourceT) -- контекст в котором можно безопасно 36 | -- создавать ресурсы, которые гарантировано 37 | -- освободятся несмотря на исключения и прочее 38 | -- нету проблем с вложенностью, которое есть 39 | -- у @try { } finally { }@ 40 | import Data.ByteString (ByteString) 41 | import Data.Conduit.Combinators (repeatM) 42 | import Data.Conduit.Network -- работа с сетью 43 | -- INFO: for_ 44 | -- достаточно интересная штука позволяет итерироваться по структуре 45 | -- игнориря результат, и нам важны только эффекты. Аналог 46 | -- 47 | -- @ 48 | -- for (x : structure.iterator() { 49 | -- @ 50 | -- 51 | -- Может использоваться для списков, множеств, но например для @Maybe@ или @Either@, 52 | -- которые делают действие только если значение есть. 53 | import Data.Foldable (for_) 54 | import Data.List.NonEmpty (NonEmpty(..)) -- Непустой список 55 | import qualified Data.Set as Set 56 | import qualified Protocol 57 | import Protocol.Errors 58 | import Protocol.Replies 59 | import Protocol.Types 60 | import qualified Protocol.Wire as Wire 61 | import Server.Handler as Handler 62 | import Server.Internal (ServerState, ChannelState(..), withServerState) 63 | import qualified Server.Channel as Channel 64 | import qualified Server.User as User 65 | import Uni 66 | 67 | -- | Функция нашего сервера. Которую будет выполнять executabe 68 | server :: ServerSettings -> IO () 69 | server settings = withServerState $ \s -> -- мы работаем с состоянием сервера 70 | -- к которому у нас нету прямого доступа 71 | -- но которое передается в обработчик 72 | runTCPServer settings $ -- запускаем TCP сервер 73 | asyncClient Protocol.protocol (clientConduit s) -- для пользователей мы используем 74 | -- асинхронный вариант, определенный 75 | -- протокол. и 'clientConduit' вместо 76 | -- логики обработчиков. 77 | 78 | -- | Вспомогательная функция, которая отправляет ответы, пользователю. 79 | -- Данная функция гарантирует, что все выделенные ресурсы будут освобождены, 80 | -- по завершеню функции, будь то нормальный выход или исключение. 81 | -- 82 | -- INFO RTS: 83 | -- Про рантайм систему в Haskell (да и прочих ЯП с зелеными потоками) можно думать, как об 84 | -- высокоуровневым интерфейсом над epoll, каждый поток создает свой контекст, который использует 85 | -- неблокирующее IO и добавляет callback в epoll, поэтому когда хэндл становится доступен, 86 | -- то поток будет пробужден и работать. В итоге если мы хотим асинхронно читать и писать для 87 | -- каждого клиента, то мы просто делаем 2 потока, один пишет и обрабатывает сообщения, а другой 88 | -- пишет ответы (возможно асинхронно) и все радостны. что мы тут и делаем 89 | asyncClient 90 | :: forall s t . 91 | Protocol (ResourceT IO) s t ByteString -- описание протокола, подробно в Protocol.Types 92 | -- тут важно, что @s@ тип который отдает протокол, @t@ входящий тип, @ByteString@ - тип в проводе. 93 | -> ((s -> STM ()) -> ConduitT t Void (ResourceT IO) ()) -- пользовательский протокол обработки сообщений 94 | -- INFO: тут можно поговорить подольше об абстракции и всем таком, но мне лень. Суть в том, 95 | -- что логике внутри совершенно нету разници до того, как огранизовано общение. Ей только 96 | -- достаточно знать как послать ответ пользователю, поэтому мы передаем callback @(s -> STM ()@ 97 | -- т.е. функция, которая получает ответ, и вызывает STM транзакцию. При реализации логики 98 | -- мы в праве выбирать любую, например подставлять тестовую. 99 | -> AppData -- структура хранящая информацию о приложении 100 | -> IO () 101 | asyncClient protocol f ad = do 102 | q <- newTQueueIO -- создали очередь, тут можно делать хитро 103 | -- и можно использовать разные очереди, например 104 | -- буфферизованную, чтобы ограничить использование 105 | -- памяти и т.п. 106 | race_ (replier q) -- Запускаем 2 легких потока для чтения и записи. 107 | (receiver q) -- Если один завершается, то другой тоже. 108 | where 109 | -- Вспомогательная функция - бесконечно читаем из очереди 110 | waitForMsg q = repeatM $ liftIO $ atomically $ readTQueue q 111 | replier :: TQueue s -> IO () 112 | replier q = runResourceT $ runConduit 113 | $ waitForMsg q -- Получаем сообщения 114 | .| encodeStream protocol -- Кодируем сообщение в байты 115 | .| appSink ad -- Отдаем клиенту 116 | receiver :: TQueue s -> IO () 117 | receiver q = runResourceT -- Контролируем ресурсы 118 | $ runConduit $ appSource ad -- Читаем данные из сокета 119 | .| decodeStream protocol -- Декодируем их в текст (utf8) 120 | .| f (writeTQueue q) -- Обрабатываем 121 | -- INFO: conduit 122 | -- при построении control flow такими блоками можно делать аналог unix pipes, 123 | -- когда мы пишем простые блоки и комбинируем из них результат. При этом они 124 | -- хорошо оптимизируются и fuse-ятся (т.е. происходит операция инлайна, специализации 125 | -- и оптимизации) таким образом по скорости код не отличается от того, если 126 | -- написать все в куче и проделать оптимизации самим (например на си). 127 | -- А так вроде понятнее 128 | 129 | 130 | -- В общем на этом сам сервер закончился, все :). 131 | -- Теперь уже сама реализация. 132 | 133 | -- Сам поток клиента 134 | clientConduit 135 | :: ServerState -- Состояние сервера 136 | -> (Wire.Message -> STM ()) -- callback переданный от tcp сервера 137 | -> ConduitT Protocol.Message a (ResourceT IO) () -- ой! 138 | clientConduit ss sendBack = do 139 | hdl <- greeting -- привествие, мы должны получить 140 | -- информацию о том, как запускать 141 | -- транзацкии 142 | 143 | awaitForever $ \case -- мы бесконечно ждем сообщения 144 | -- и обрабатываем их 145 | Protocol.Join channel -> -- команда JOIN 146 | -- Вот тут интересно, мы явно описываем все возможные исключения, точнее на 147 | -- самом деле компилятор сам нам их рассказывает, так что программист видит, 148 | -- что может индти не так. Эта магия, которую наверное делать не надо, но 149 | -- раз можно то почему бы и да. 150 | -- 151 | -- run запускает транзацию. см. Handler 152 | runHandler hdl @ '[UserOnChannel] $ 153 | Channel.with_ channel $ \state -> do -- работаем с каналом, создать если нету 154 | nick <- askNickname -- получили текущий ник 155 | state' <- Channel.addUser state nick -- добавить юзера на канал 156 | reply $ ReplyTopic channel (channelTopic state') -- анонисировали пользоватею топик 157 | reply $ NamReply channel (channelUsers state') -- анонсировали список юзеров 158 | pure state' 159 | Protocol.Part channel reason -> -- команда PART 160 | runHandler hdl @'[NotOnChannel, NoSuchChannel] $ do 161 | nick <- askNickname 162 | Channel.with'_ channel $ \state -> -- работаем с каналом, исключение если нету 163 | Channel.partUser state nick reason -- убрать пользователя. 164 | updateUserChannels $ Set.delete channel -- убрать информацию о канале 165 | Protocol.PrivMsg (Wire.MsgTarget target) msg -> -- отправить сообщение 166 | for_ target $ \to -> -- для каждого получателя из списка 167 | -- отдельная транзакция 168 | runHandler hdl @ '[NoSuchNick, NoSuchChannel, NotOnChannel] $ 169 | case to of 170 | MsgToChannel channel -> do -- сообщение на канал 171 | nick <- askNickname 172 | state <- Channel.get channel -- получить канал 173 | unless (nick `Channel.member` state) -- проверить, что пользователь там есть 174 | $ throwHandler $ inj $ NotOnChannel channel 175 | -- отправить сообщение, тут бы не помеша комбинатор какой. PR welcome, все дела. 176 | let cmd' = Protocol.PrivMsg (Wire.MsgTarget $ MsgToChannel channel :| []) msg 177 | -- отправить сообщение, в канал. 178 | Channel.send state $ Handler.Message nick cmd' 179 | MsgToUser to' -> do 180 | nick <- askNickname 181 | state <- User.get to' 182 | let cmd' = Protocol.PrivMsg (Wire.MsgTarget $ MsgToUser to' :| []) msg 183 | User.send state $ Handler.Message nick cmd' 184 | Protocol.Nick _newnick -> pure () -- лень, сами добавляейте. 185 | where 186 | -- не стоит тут пытаться писать тип, если что я предупреждаел 187 | greeting = await >>= \case 188 | Nothing -> error "user exit before handshake" -- Ахахаха! 189 | Just (Protocol.Nick nick) -> -- пользователь регистрируется 190 | -- Ух, 191 | -- @join :: m (m a) -> m a@ - "сворачивает контекст". В данном примере используется 192 | -- для того, чтобы выполнить действия после STM транзакции, поскольку в транзакции 193 | -- мы не можем делать эффекты, которые нельзя повторять или прервать в середине или 194 | -- которые создают эффекты в реальном мире. 195 | -- поэтому мы далаем @join $ atomically $ trasaction >> return action@ что происходит 196 | -- мы выполняем транзацию и возвращаем действие как результат, получается: 197 | -- @join (action:: IO (IO a))@ которое выполняет это действие @action@. 198 | -- Можно просто запомнить этот трюк. 199 | join $ liftIO $ atomically $ do 200 | eresult <- register ss nick sendBack -- регистрируем пользователя 201 | case eresult of 202 | Left e -> sendBack (errorToWire e) >> pure greeting -- не удалось, отправили ошибку и заново 203 | Right reg -> pure (lift reg) -- удалось, регистрируем пользователя 204 | -- теперь если этот тред умрёт, то 205 | -- пользователь не забудет выйти с 206 | -- каналов. 207 | _ -> greeting -- можно и тут ошибку послать, но мне лень. 208 | 209 | -- Вроде все немногословно и достаточно просто, и можно ещё почище сделать 210 | -- главное, что это уже можно тестировать и изменять. 211 | -------------------------------------------------------------------------------- /src/Server/Channel.hs: -------------------------------------------------------------------------------- 1 | -- | Работа с каналами. 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Server.Channel 5 | ( with_ 6 | , with'_ 7 | , addUser 8 | , partUser 9 | , get 10 | , member 11 | , Server.Channel.send 12 | ) where 13 | 14 | import Control.Concurrent.STM 15 | import Control.Monad.Base 16 | import Control.Monad.Except 17 | import Data.Foldable 18 | import qualified Data.Map as Map 19 | import qualified Data.Set as Set 20 | import Data.Text (Text) 21 | import qualified Protocol 22 | import Protocol.Errors 23 | import Protocol.Types (Nickname, Channel) 24 | import Server.Internal as Internal 25 | import Uni 26 | 27 | -- | Работа с каналом. Если канала нету, то он создается. 28 | -- 29 | -- Тут у нас есть следующие контексты: 30 | -- MonadBase STM - ура мы можем делать транзакции, и не можем делать 31 | -- произвольно еIO 32 | -- HasServerState - у нас есть доступ к состоянию сервера 33 | -- 34 | -- У нас есть 2 кандидата для контекста где мы можем это выполнять 35 | -- 36 | -- ReaderT ServerState 37 | -- Handler e 38 | -- 39 | -- Чем мы и пользуемся 40 | with_ :: (MonadBase STM m, HasServerState m) 41 | => Channel -> (ChannelState -> m ChannelState) -> m () 42 | with_ channel = withInternal (pure $ ChannelState Set.empty "" channel) channel 43 | 44 | -- | Работа с каналом. Если канала нету, то он исключение 45 | -- 46 | -- Тут появляется ещё и новый контекст, что мы можем вернуть ошибку e, 47 | -- и сделать инъекцию из NoSuchChannel в e. 48 | with'_ :: (Inj e NoSuchChannel, MonadBase STM m, HasServerState m, MonadError e m) 49 | => Channel -> (ChannelState -> m ChannelState) -> m () 50 | with'_ channel = withInternal (throwError $ inj $ NoSuchChannel channel) channel 51 | 52 | -- Функция для написания двух выше, вообще так любят писать в ФП 53 | -- что много разных вещей можно выразить через общий набор примитивов 54 | withInternal 55 | :: (MonadBase STM m, HasServerState m) 56 | => m ChannelState -- что делать если канала нету 57 | -> Channel -- имя канала 58 | -> (ChannelState -> m ChannelState) -- операция над состоянием 59 | -> m () 60 | withInternal onNothing channel f 61 | = askServerChannels >>= 62 | maybe onNothing pure . Map.lookup channel >>= 63 | f >>= updateServerChannels channel 64 | 65 | -- получить состояние канала, и ошбику если нету 66 | get :: (Inj e NoSuchChannel, MonadBase STM m, HasServerState m, MonadError e m) 67 | => Channel 68 | -> m ChannelState 69 | get chan = do 70 | channels <- askServerChannels 71 | case Map.lookup chan channels of 72 | Nothing -> throwError $ inj $ NoSuchChannel chan 73 | Just x -> pure x 74 | 75 | -- | Добавить пользователя на канал 76 | addUser :: (Inj e UserOnChannel, MonadBase STM m, HasServerState m, MonadError e m) 77 | => Internal.ChannelState 78 | -> Nickname 79 | -> m ChannelState 80 | addUser state nick = do 81 | let channel = channelName state 82 | when (Set.member nick (channelUsers state)) $ -- Проверили, что пользователь не на канале 83 | throwError $ inj $ UserOnChannel nick channel -- вернули ошибку 84 | let users' = Set.insert nick (channelUsers state) -- добавили пользователя 85 | state' = state{channelUsers = users'} 86 | Server.Channel.send state' $ Message nick (Protocol.Join channel) -- анонсировали вход на канал 87 | pure state' 88 | 89 | -- | Пользователь выходит с канала. 90 | partUser :: (Inj e NotOnChannel, MonadBase STM m, HasServerState m, MonadError e m) 91 | => ChannelState 92 | -> Nickname 93 | -> Maybe Text 94 | -> m ChannelState 95 | partUser state nick reason = do 96 | let channel = channelName state 97 | unless (Set.member nick (channelUsers state)) 98 | $ throwError $ inj $ NotOnChannel channel 99 | let state' = state {channelUsers = Set.delete nick (channelUsers state)} 100 | Server.Channel.send state' $ Message nick (Protocol.Part channel reason) 101 | pure state' 102 | 103 | send :: (MonadBase STM m, HasServerState m) 104 | => ChannelState 105 | -> Message 106 | -> m () 107 | send state msg = 108 | for_ (channelUsers state) $ \nick -> Internal.send nick msg 109 | 110 | member :: Nickname -> ChannelState -> Bool 111 | member n state = Set.member n (channelUsers state) 112 | -------------------------------------------------------------------------------- /src/Server/Handler.hs: -------------------------------------------------------------------------------- 1 | -- Это модуль для обработчиков. Тут уже начинаются интересные моменты. 2 | -- Предполагается, что код будет рабоать с сервером через этот интерфейс 3 | -- который описывает какие возможности есть у пользователя. 4 | -- Я решил продемонтсрировать работу с STM тут, с одной стороны это 5 | -- не полезно для сервера, но с другой дает интересные свойства, которые 6 | -- могут быть нужны в других проектах. Так же демонстрирует то, какие 7 | -- возможности может дать чистота языка. 8 | -- Да, STM такое какое оно здесь работает благодаря чистоте, это значит 9 | -- что мы можем использовать оптимистическую блокировку, и спокойно 10 | -- переигрывать транзакции и использовать полный сабсет языка в них. 11 | -- 12 | -- Зачем все это нужно - с транзакциями мы получаем гарантии консистентности, 13 | -- и уменьшение race conduitions. Например: 14 | -- 15 | -- 1. Вы никогда не получите сообщение от пользователя в канал до того 16 | -- как он вошёл 17 | -- 18 | -- 2. Если вы видите сообщение, то оно было отправлено всем пользователям 19 | -- которых вы видите на канале 20 | -- 21 | -- 3. Все пользователи видят все сообщения в однои и том же порядке. 22 | -- 23 | -- Тут можно заменить, что я говорию про отправку, а не доставку, с гарантированной 24 | -- доставкой все становится интереснее, но irc не об этом, там даже описанных гарантий, 25 | -- 26 | -- INFO В этом модуле мы знакомимся с понятием стека эффектов и тем, как его можно использовать. 27 | -- Отличие от обычных языков, в том, что мы рассматриваем различные возможности не 28 | -- как отдельные компоненты моделируемые объектом, а как слои, например в слое 29 | -- 30 | -- @Reader T@ - любое действие может получить доступ к значению T лежищем в окружении 31 | -- @(->) T@ - тоже самое, да просто функция 32 | -- @Writer T@ - все функции могут писать лог, на самом деле это контекст для создания 33 | -- утечек памяти 34 | -- @State T@ - есть доступ к чистому состоянию 35 | -- @STM@ - можно делать STM операции, формирующие транзакцию 36 | -- @IO@ - можно всё! 37 | -- @...@ - и много чего ещё 38 | -- 39 | -- Данные слои это не ограничение допустимых операций и система меток (что тоже есть), 40 | -- а наоборот добавление структур позволяющих делать с ними, что-то новое. При этом 41 | -- мы можем складывать слои один с другим формируя стек. например 42 | -- 43 | -- @ReaderT Env IO@ - окружение в котором есть доступ до значения типа Env и I/O операции 44 | -- 45 | -- Явно использовать стек не всегда удобно, поскольку это дает runtime оверхед да и 46 | -- нужно использовать спец операцию lift, в общем неудобно. Вместо этого можно задавать 47 | -- интерфейсы от слоя и тогда делать один слой предоставляющий разные интерфейсы. 48 | -- А раз можно то будем использовать все! когда что удобнее 49 | 50 | {-# LANGUAGE DataKinds #-} 51 | {-# LANGUAGE TypeApplications #-} 52 | {-# LANGUAGE OverloadedStrings #-} -- Позволяет использовать синтаксис "fff" для задания 53 | -- значений типов отличных от строк. 54 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- Уменьшаем количество бойлерплейта 55 | {-# LANGUAGE FlexibleContexts #-} 56 | {-# LANGUAGE RankNTypes #-} -- Ой все, сложно 57 | -- | 58 | -- Модуль для пользовательского обработчика событий, в нём хранится дополнительная 59 | -- информация о состоянии пользователя. 60 | module Server.Handler 61 | ( Handler(..) 62 | , RunHandler(..) 63 | , HandlerState(..) 64 | , UserState 65 | , Server.Internal.Message(..) 66 | , reply 67 | , unregister 68 | , Server.Handler.register 69 | , throwHandler 70 | , askNickname 71 | , updateUserChannels 72 | ) where 73 | 74 | -- INFO: Интерфейс, который говорит, что данный стек построен на какой-то базовом контексте, 75 | -- обычно STM или IO. И мы можем операцию из этой базового контекста превратить в операцию 76 | -- в контесте где мы работаем. Такая операция не будет иметь доступа к состоянию нашего конткста 77 | -- Пример: 78 | -- 79 | -- @ 80 | -- liftBase (readTVar a) :: ReaderT Env STM A 81 | -- @ 82 | -- 83 | -- Делает из STM операции операцию в нашем контексте. 84 | import Control.Monad.Base 85 | import Control.Monad.Reader -- Интерфейс для Reader 86 | import Control.Monad.Trans.Resource as Resource 87 | import Control.Monad.Except -- Интерфейс для контекста, 88 | -- который может останавливаться с ошибкой 89 | import Control.Monad.Trans.Except -- Реализация слоя для операций с ошибкой/исключением 90 | import Control.Concurrent.STM -- STM слой/контекст 91 | import Data.Set (Set) -- Немного структур данных 92 | import qualified Data.Set as Set -- Квалифицированный импорт можно использовать методы 93 | -- как Set.method 94 | import qualified Data.Map as Map 95 | import Data.Foldable (for_) 96 | import Protocol.Types -- Наши типы и данные 97 | import Protocol.Errors 98 | import qualified Protocol.Wire as Wire 99 | import qualified Server.Channel as Channel 100 | import Server.Internal 101 | import Uni -- ^_^ 102 | 103 | -- | Состояние обработчика, это то новое состояние, которого нету 104 | -- в обычной работе сервера, и к которому мы получаем доступ, когда 105 | -- вызываем обработчик. Т.о. сам сервер не может в нём копаться и ломать 106 | -- наше состояние, пока мы сами этого не попросили 107 | data HandlerState = HandlerState 108 | { handlerReply :: Wire.Message -> STM () -- ^ Функция для обратной связи 109 | , handlerState :: ServerState -- ^ Доступ к состоянию сервера 110 | , handlerUser :: UserState -- ^ Состояние текущего пользователя 111 | } 112 | 113 | -- | Состояние пользователя. Информация ассоциированная с тредом пользователя. 114 | -- важно, что тут мы используем изменяемые переменные. В принципе все можно бы 115 | -- было выразить через чистый State, но поскольку мы работаем не с чистыми 116 | -- вычислениями и финализация зависит от этих значений, то нам приходится 117 | -- использовать мутабельные переменные, иначе при исключении мы потеряем 118 | -- доступ к контексту. 119 | data UserState = UserState 120 | { userNickname :: TVar Nickname -- ^ имя пользователя 121 | , userChannels :: TVar (Set Channel) -- ^ список каналов 122 | } 123 | 124 | -- | Контекст в котором ведётся работа, он предоставляет интерфейс к окружению (HandlerState) 125 | -- 1. Состояние пользователя 126 | -- 2. Состояние сервера 127 | -- 3. Возможность общаться с пользователем 128 | -- 129 | -- Позволяет описывать возможноые ошибки ExceptT e 130 | -- 131 | -- Выполняется в STM 132 | -- 133 | -- из него у нас создан стек и нам хочется рассказать, что он обладает описанными выше 134 | -- интерфейсами, что мы делаем через deriving. Как это работает: т.е. это у нас тип 135 | -- обертка 'newtype' а для внутренних типов есть нужные интерфейсы, то мы просто 136 | -- говорим компилятору, примени для необернутого типа, и оберни - дешево и сердито. 137 | -- 138 | -- Этот слой постоен поверх серверного слоя и главное что он дает это возможность 139 | -- прямого общения с пользотваелем (reply + ошбики) и имеет состояние пользователя. 140 | newtype Handler e a = Handler { unHandler :: ReaderT HandlerState (ExceptT e STM) a } 141 | deriving (Functor,Applicative, Monad, MonadBase STM, MonadReader HandlerState, MonadError e) 142 | 143 | -- | АААААААААА страшная штука? Так выглядит динамическая диспатчеризация, на самом 144 | -- деле динамическая. Ну обо всем подробнее, так мы храним функцию, которая может 145 | -- исполнять 'Handler', который там передали, причем его тип там заранее (в компайл тайме) 146 | -- не известен, а именно - нам не известен тип ошибки, которые могут возникать. 147 | -- Более того, мы можем выполнять хэндлен разных контекстах (известных в compile time). 148 | -- 149 | -- Аналог псевдокод 150 | -- @ 151 | -- class Runner { 152 | -- M run(handler : Handler) { ... } 153 | -- @ 154 | -- 155 | -- можно и без этого было обойтись, используя расширяемые исключения, но у меня появился 156 | -- шанс показать динамическую диспетчеризацию. Да и возращение функцонального объекта тоже. 157 | -- 158 | -- Использя этот объект мы можем спрятать все приватное состояние в функцию, 159 | -- и позволять пользователю запускать обработчики, при этом не отдавая им информацию 160 | -- о внутренем состоянии. Так же аналог это handle pattern, но мы ж не знаем требований 161 | -- и хотим сделать общий вариант. 162 | newtype RunHandler m = RunHandler { 163 | runHandler :: forall e. (IsCodeError (Uni e), Monad m) 164 | => Handler (Uni e) () 165 | -> m () 166 | } 167 | 168 | -- | И у нас есть возможность использовать методы из внутреннего интерфейса 169 | -- 170 | -- Этот слой говорит о том, что у нас есть доступ с состоянию сервера и мы можем 171 | -- использять операции из того слоя 172 | instance HasServerState (Handler e) where 173 | askServerState = asks handlerState 174 | 175 | -- | Обновить список каналов пользователя. (Boilderplate!) 176 | -- 177 | -- XXX: лично мне не нравится эта штука, я бы лучше сделал явное API 178 | -- в Server.User, которое бы принимало атомарные операции, а не этот 179 | -- @(Set Channel -> Set Channel)@ 180 | updateUserChannels :: (Set Channel -> Set Channel) -> Handler e () 181 | updateUserChannels f = do 182 | channels <- asks (userChannels . handlerUser) 183 | liftBase $ modifyTVar channels f -- вот тут мы поднимаем STM в наш Handler 184 | 185 | -- | Получить имя пользователя 186 | askNickname :: Handler e Nickname 187 | askNickname = liftBase . readTVar =<< asks (userNickname.handlerUser) 188 | 189 | -- | Выкинуть ошибку 190 | throwHandler :: e -> Handler e a 191 | throwHandler e = Handler $ ReaderT $ \_ -> throwE e 192 | 193 | -- | Регистрация пользователя в системе. 194 | register 195 | :: forall m .MonadIO m -- в любом контексте где можно IO 196 | => ServerState 197 | -> Nickname 198 | -> (Wire.Message -> STM ()) -- уже знакомая функция для отправки 199 | -- сообщения пользователю 200 | -- Тут мы возвращаем или ошибку о том, что ник уже используется или 201 | -- объект, который позволяет исполнять обработчики. В ответ мы возвращаем действие 202 | -- которое должно быть исполнено, там где пользователь это может сделать 203 | -> STM (Either NickNameInUse (ResourceT IO (RunHandler m))) 204 | register ss nick call = flip runReaderT ss $ do 205 | users <- askServerUsers -- Получили список пользователлй 206 | case Map.lookup nick users of -- посмотрели занят ли ник 207 | Nothing -> lift $ do -- не занят 208 | state <- UserState <$> newTVar nick -- создали новое состояние (комтекст - STM) 209 | <*> newTVar Set.empty 210 | flip runReaderT ss $ -- добавили информацию о пользователе 211 | -- тут интересно, то что мы сохранили новый callback который работает 212 | -- с серверными сообщениями, т.к. в них есть под инфа о настоящем отправителе 213 | updateServerUsers $ Map.insert nick (UserInfo $ call .Wire.toMessage) 214 | -- генерируем ответ 215 | pure $ Right $ do 216 | -- Регистрируем финализатор, если тред умрет, то пользователь выйдет 217 | _ <- Resource.register (atomically $ unregister ss state) 218 | -- создаем запускатр 219 | pure $ RunHandler $ \f -> do 220 | eresult <- liftIO $ atomically -- запускаем транзакцию 221 | $ runUni -- которая вернёт результат или ошибку 222 | $ runReaderT (unHandler f) (HandlerState call ss state) 223 | case eresult of 224 | -- если ошибка, то конвертируем её в сообщение и отправим в сеть 225 | Left problem -> liftIO $ atomically $ call $ errorToWire problem 226 | Right _ -> pure () 227 | Just _ -> pure $ Left $ NickNameInUse nick 228 | 229 | -- | пользователь ушёл 230 | unregister :: ServerState 231 | -> UserState 232 | -> STM () 233 | unregister ss state = do 234 | nick <- readTVar $ userNickname state 235 | uch <- readTVar $ userChannels state 236 | runReaderT (updateServerUsers $ Map.delete nick) ss -- убрали из списка 237 | for_ uch $ \ch -> runUni @[NotOnChannel, NoSuchChannel] $ 238 | flip runReaderT ss $ do 239 | st <- Channel.get ch 240 | Channel.partUser st nick (Just "connection closed..") -- послали PART сообщение 241 | 242 | -- | Отправить сообщение пользователю вызывающему хендлер. Обычно используется 243 | -- для передачи ответов на сообщения и ошибках. 244 | reply :: Wire.IsMessage a => a -> Handler e () 245 | reply msg = do 246 | go <- asks handlerReply 247 | liftBase $ go $ Wire.toMessage msg 248 | -------------------------------------------------------------------------------- /src/Server/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} -- Смешные расширения, компилятор говорит сам, 2 | {-# LANGUAGE FlexibleContexts #-} -- когда они нужны. 3 | 4 | -- | 5 | -- Внутренняя часть сервера и используемые структуры данных 6 | -- Данный уроверь может предоставлять доступ к внутреннему 7 | -- интерфейсу и отвечает за отправку сообщений между пользователями. 8 | module Server.Internal 9 | ( ServerState 10 | , withServerState 11 | -- * API 12 | , HasServerState(..) 13 | , askServerChannels 14 | , updateServerChannels 15 | , askServerUsers 16 | , updateServerUsers 17 | , send 18 | -- * Types 19 | , Channel(..) 20 | , ChannelState(..) 21 | , UserInfo(..) 22 | , Message(..) 23 | ) where 24 | 25 | import Control.Concurrent.STM 26 | import Control.Exception 27 | import Control.Monad.Base 28 | import Control.Monad.Reader 29 | import Data.Foldable (for_) 30 | import Data.Map (Map) 31 | import qualified Data.Map as Map 32 | import Data.Set (Set) 33 | import Data.Text (Text) 34 | import Protocol (Nickname, Channel) 35 | import qualified Protocol 36 | import qualified Protocol.Wire as Wire 37 | 38 | 39 | -- | безопасное использование ресурса, аналог @try {} finally {}@ 40 | withServerState :: (ServerState -> IO a) -> IO a 41 | withServerState = 42 | bracket (ServerState <$> newTVarIO Map.empty 43 | <*> newTVarIO Map.empty) 44 | (\_ -> pure ()) 45 | 46 | -- | Сообщения, которыми общается сервер, отличается тем, что нём 47 | -- используется префикс реального пользователя. 48 | data Message = Message 49 | { _smTarget :: Nickname 50 | , _smMessage :: Protocol.Message 51 | } 52 | 53 | -- Такое сообщенгие может быть конвертировано в нетипизированное 54 | instance Wire.IsMessage Message where 55 | toMessage (Message nm p) = case Wire.toMessage p of 56 | Wire.Message _ a b c -> Wire.Message (Just $ Wire.Prefix nm) a b c 57 | 58 | -- | Состояние сервера. 59 | data ServerState = ServerState 60 | { serverUsers :: TVar (Map Nickname UserInfo) 61 | , serverChannels :: TVar (Map Channel ChannelState) 62 | } 63 | 64 | -- | Состояние канала. 65 | -- 66 | -- XXX: сильно упрощено, т.к. не хранится информация о модах, банах и 67 | -- привелегиях на канале. 68 | data ChannelState = ChannelState 69 | { channelUsers :: Set Nickname 70 | , channelTopic :: Text 71 | , channelName :: Channel 72 | } 73 | 74 | -- | Информация о пользователе, канал, который используется для 75 | -- отправки сообщений. 76 | newtype UserInfo = UserInfo 77 | { userQueue :: Message -> STM () 78 | } 79 | 80 | -- | Интерфейс описывающий то, что возможна работа с состоянием 81 | class HasServerState m where 82 | askServerState :: m ServerState 83 | 84 | instance Monad m => HasServerState (ReaderT ServerState m) where 85 | askServerState = ask 86 | 87 | -- Куча вспомогательных функций 88 | 89 | askServerUsers :: (MonadBase STM m, HasServerState m) => m (Map Nickname UserInfo) 90 | askServerUsers = 91 | liftBase . readTVar =<< fmap serverUsers askServerState 92 | 93 | updateServerUsers :: (MonadBase STM m, HasServerState m) 94 | => (Map Nickname UserInfo -> Map Nickname UserInfo) 95 | -> m () 96 | updateServerUsers f = do 97 | users <- fmap serverUsers askServerState 98 | liftBase $ modifyTVar users f 99 | 100 | askServerChannels :: (MonadBase STM m, HasServerState m) => m (Map Channel ChannelState) 101 | askServerChannels = 102 | liftBase . readTVar =<< fmap serverChannels askServerState 103 | 104 | updateServerChannels :: (MonadBase STM m, HasServerState m) => Channel -> ChannelState -> m () 105 | updateServerChannels ch st = do 106 | tv <- fmap serverChannels askServerState 107 | liftBase $ modifyTVar tv $ Map.insert ch st 108 | 109 | -- | Отправить сообщение пользователю. 110 | send :: (MonadBase STM m, HasServerState m) => Nickname -> Message -> m () 111 | send to (Message nickname msg) = do 112 | users <- askServerUsers 113 | for_ (Map.lookup to users) $ \ustate -> 114 | liftBase $ userQueue ustate $ Message nickname msg 115 | -------------------------------------------------------------------------------- /src/Server/User.hs: -------------------------------------------------------------------------------- 1 | -- Не особо интересный файл, который предоставляет API для работы с 2 | -- пользователем 3 | {-# LANGUAGE FlexibleContexts #-} 4 | module Server.User 5 | ( UserInfo(..) 6 | , get 7 | , Server.User.send 8 | ) where 9 | 10 | import Control.Monad.Base 11 | import Control.Concurrent.STM 12 | import Control.Monad.Except 13 | import Protocol.Types hiding (Message) 14 | import Protocol.Errors 15 | import qualified Data.Map as Map 16 | import Server.Internal 17 | import Uni 18 | 19 | get :: (Inj e NoSuchNick, HasServerState m, MonadError e m, MonadBase STM m) 20 | => Nickname 21 | -> m UserInfo 22 | get nickname = do 23 | users <- askServerUsers 24 | case Map.lookup nickname users of 25 | Nothing -> throwError $ inj $ NoSuchNick nickname 26 | Just x -> pure x 27 | 28 | send :: (MonadBase STM m) => UserInfo -> Message -> m () 29 | send (UserInfo run) msg = liftBase $ run msg 30 | 31 | -------------------------------------------------------------------------------- /src/Uni.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE ExplicitForAll #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | module Uni 10 | ( Inj(..) 11 | , Uni(..) 12 | , runUni 13 | ) where 14 | 15 | import Control.Monad.Trans.Except 16 | 17 | runUni :: forall t m a . Monad m 18 | => ExceptT (Uni t) m a 19 | -> m (Either (Uni t) a) 20 | runUni = runExceptT 21 | 22 | data Uni (a:: [*]) where 23 | That :: Uni b -> Uni (a ': b) 24 | This :: a -> Uni (a ': b) 25 | 26 | 27 | class Inj o i where 28 | inj :: i -> o 29 | 30 | instance {-# OVERLAPPABLE #-} Inj a a where 31 | inj = id 32 | 33 | instance Inj (Maybe a) a where 34 | inj = Just 35 | 36 | 37 | instance {-# OVERLAPPABLE #-} Inj (Uni b) c => Inj (Uni (a ': b)) c where 38 | inj = That . inj 39 | 40 | instance {-# OVERLAPS #-} Inj (Uni (a ': b)) a where 41 | inj = This 42 | 43 | -------------------------------------------------------------------------------- /tests/Test/Protocol/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Test.Protocol.Parser 5 | ( tests 6 | ) where 7 | 8 | import Control.Lens 9 | import Control.Applicative 10 | import Data.Attoparsec.Text 11 | import Data.Coerce 12 | import Data.Monoid 13 | import Data.String 14 | import Protocol.Wire (message, toWire) 15 | import Protocol.Types 16 | import qualified Data.Text as Text 17 | import qualified Data.Text.Lazy.Builder as TextL 18 | import qualified Data.Text.Lazy as TextL 19 | import Test.Tasty 20 | import Test.Tasty.HUnit 21 | import Test.Tasty.SmallCheck as SC 22 | import Test.SmallCheck.Series (Serial(..), decDepth) 23 | import qualified Test.SmallCheck.Series as SC 24 | 25 | tests :: TestTree 26 | tests = testGroup "parser" 27 | [ testGroup "RFC examples" testsRFC 28 | -- , testGroup "properties" testProp 29 | ] 30 | 31 | testsRFC = map (uncurry mkTest) 32 | [ ("NICK Wiz", 33 | mkTextCommand "NICK" & params .~ ["Wiz"]) 34 | --, (":WiZ!jto@tolsun.oulu.fi NICK Kilroy", 35 | -- mkTextCommand "JOIN" & prefix .~ (Just ":WiZ!jto@tolsun.oulu.fi") 36 | -- & params .~ ["Kilroy"]) 37 | , ("JOIN #foobar", Message Nothing "JOIN" ["#foobar"] Nothing) 38 | , ("JOIN &foo fubar", Message Nothing "JOIN" ["&foo", "fubar"] Nothing) 39 | , ("JOIN #foo,&bar fubar", Message Nothing "JOIN" ["#foo,&bar", "fubar"] Nothing) 40 | -- , (":WiZ!jto@tolsun.oulu.fi JOIN #Twilight_zone" 41 | -- , Message (Just "WiZ!jto@tolsun.oulu.fi") "JOIN" ["#Twilight_zone"] Nothing) 42 | , ("PART #twilight_zone", 43 | Message Nothing "PART" ["#twilight_zone"] Nothing) 44 | , (":WiZ PART #playzone :I lost", 45 | mkTextCommand "PART" & prefix .~ (Just "WiZ") 46 | & params .~ ["#playzone"] 47 | & trailing .~ Just "I lost") 48 | , (":Angel PRIVMSG Wiz :Are you receiving this message ?", 49 | mkTextCommand "PRIVMSG" & prefix .~ (Just "Angel") 50 | & params .~ ["Wiz"] 51 | & trailing .~ Just "Are you receiving this message ?") 52 | , ("PRIVMSG Angel :yes I'm receiving it !", 53 | Message Nothing "PRIVMSG" ["Angel"] (Just "yes I'm receiving it !")) 54 | ] 55 | where 56 | mkTest msg pattern = testCase msg $ parseOnly message (fromString msg <> "\r\n") @?= Right pattern 57 | 58 | {- 59 | 60 | testProp = 61 | [ SC.testProperty "parse . toWire == id" $ 62 | \msg -> 63 | let s = TextL.toStrict $ TextL.toLazyText $ toWire msg 64 | a = parseOnly message s 65 | b = Right msg :: Either String Message 66 | in if a == b then Right ("OK"::String) 67 | else Left $ unlines [ "Request: " <> show msg 68 | , "Line: " <> show (Text.unpack s) 69 | , "Result: " <> show a 70 | ] 71 | ] 72 | 73 | instance Monad m => Serial m Channel where 74 | series = coerce . Text.pack <$> series 75 | instance Monad m => Serial m Nickname where 76 | series = coerce . Text.pack <$> series 77 | instance Monad m => Serial m Command where 78 | series = TextCommand . Text.pack . SC.getNonEmpty <$> series 79 | <|> IntCommand <$> series 80 | instance Monad m => Serial m Code 81 | instance Monad m => Serial m Message where 82 | series = decDepth $ Message <$> series 83 | <*> series 84 | <*> series 85 | <*> fmap (fmap Text.pack) series 86 | instance Monad m => Serial m Prefix where 87 | series = coerce . Text.pack <$> series 88 | instance Monad m => Serial m Param where 89 | series = coerce . Text.pack <$> series 90 | -} 91 | -------------------------------------------------------------------------------- /tests/unit.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | where 3 | 4 | import Test.Tasty 5 | import qualified Test.Protocol.Parser 6 | 7 | main = defaultMain $ 8 | testGroup "unit" 9 | [ Test.Protocol.Parser.tests 10 | ] 11 | --------------------------------------------------------------------------------