├── .gitignore ├── LICENSE ├── MinecraftCLI.cabal ├── README.md ├── Setup.hs ├── app ├── Commands.hs ├── DB.hs ├── Inventory.hs ├── ItemLookup.hs └── Main.hs ├── cbits ├── crypt.c └── crypt.h ├── src ├── Foreign │ └── Crypt.hs └── Network │ └── Protocol │ ├── Minecraft.hs │ └── Minecraft │ ├── Encoding.hs │ ├── Packet.hs │ ├── Packet │ └── TH.hs │ ├── Types.hs │ └── Yggdrasil.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | .minecraftcli_history 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Xandaros (c) 2017 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 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /MinecraftCLI.cabal: -------------------------------------------------------------------------------- 1 | name: MinecraftCLI 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/Xandaros/MinecraftCLI#readme 6 | license: BSD2 7 | license-file: LICENSE 8 | author: Xandaros 9 | maintainer: mz-bremerhaven@gmail.com 10 | copyright: (C) 2017 Xandaros 11 | category: Network 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Network.Protocol.Minecraft 19 | , Network.Protocol.Minecraft.Encoding 20 | , Network.Protocol.Minecraft.Types 21 | , Network.Protocol.Minecraft.Packet 22 | , Network.Protocol.Minecraft.Yggdrasil 23 | , Foreign.Crypt 24 | other-modules: Network.Protocol.Minecraft.Packet.TH 25 | c-sources: cbits/crypt.c 26 | extra-libraries: mcrypt 27 | include-dirs: cbits 28 | includes: cbits/crypt.h 29 | build-depends: base >= 4.7 && < 5 30 | , network 31 | , bytestring 32 | , text 33 | , asn1-encoding 34 | , asn1-types 35 | , x509 36 | , cryptonite 37 | , transformers 38 | , mtl 39 | , servant 40 | , servant-client 41 | , http-client 42 | , http-client-tls 43 | , aeson 44 | , binary 45 | , zlib 46 | , parsec 47 | , template-haskell ==2.12.0.0 48 | , lens 49 | , unordered-containers 50 | , vector 51 | default-language: Haskell2010 52 | ghc-options: -fdefer-typed-holes -Wall -Wno-name-shadowing -Wno-type-defaults 53 | 54 | executable MinecraftCLI 55 | hs-source-dirs: app 56 | main-is: Main.hs 57 | other-modules: DB 58 | , Commands 59 | , ItemLookup 60 | , Inventory 61 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 62 | build-depends: base 63 | , MinecraftCLI 64 | , reflex 65 | , lens 66 | , text 67 | , stm 68 | , async 69 | , time 70 | , hjpath 71 | , safe 72 | , persistent 73 | , persistent-sqlite 74 | , persistent-template 75 | , bytestring 76 | , aeson 77 | , reflex-host 78 | , containers 79 | , vector-sized 80 | , finite-typelits 81 | , haskeline 82 | , uuid 83 | , split 84 | default-language: Haskell2010 85 | 86 | source-repository head 87 | type: git 88 | location: https://github.com/Xandaros/MinecraftCLI 89 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # MinecraftCLI 2 | 3 | MinecraftCLI is a command line application to join Minecraft servers with a valid Mojang or Legacy account, without needing the full Minecraft client. The application has several functions as described below. 4 | 5 | ## Installation 6 | ### Dependencies: 7 | * Stack 8 | * Mcrypt 9 | 10 | ### Procedure: 11 | 1. `stack build` 12 | 2. `stack exec -- MinecraftCLI`. *Alternatively* `stack install` from project root to install to `~/.local/bin`. 13 | 14 | Note: To locate MinecraftCLI, execute `cd $(stack path --dist-dir)/build/MinecraftCLI` (bash specific) 15 | 16 | ## Usage 17 | 18 | Run the binary and a % prompt will be displayed. Enter any of the following commands and use quit to exit. 19 | 20 | ### Help 21 | 22 | Display all commands: 23 | 24 | ```javascript 25 | help 26 | ``` 27 | 28 | ### Profiles 29 | 30 | Show available commands: 31 | 32 | ```javascript 33 | profiles help 34 | ``` 35 | 36 | List all profiles: 37 | 38 | ```javascript 39 | profiles list 40 | ``` 41 | Add a new profile: 42 | 43 | ```javascript 44 | profiles new 45 | ``` 46 | Delete a profile: 47 | 48 | ```javascript 49 | profiles delete 50 | ``` 51 | 52 | ### Servers 53 | 54 | Show available commands: 55 | 56 | ```javascript 57 | servers help 58 | ``` 59 | 60 | List all servers: 61 | 62 | ```javascript 63 | servers list 64 | ``` 65 | Add a new server: 66 | 67 | ```javascript 68 | servers new 69 | ``` 70 | Delete a server: 71 | 72 | ```javascript 73 | servers delete 74 | ``` 75 | 76 | ### Connect 77 | 78 | Connect to a server specifying a user profile and a server. The profile name must match one of those listed with `profiles list` and server name must match the server name that `servers list` displays. 79 | 80 | Connect to a server: 81 | 82 | ```javascript 83 | connect 84 | ``` 85 | 86 | ### Dimension 87 | 88 | Display the Minecraft dimension that a player account is in. e.g. Overworld 89 | 90 | ```javascript 91 | dimension 92 | ``` 93 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Commands.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedStrings, MultiWayIf, DataKinds, ScopedTypeVariables, LambdaCase #-} 3 | module Commands where 4 | 5 | import Control.Lens 6 | import Control.Monad (join) 7 | import Data.List (intersperse) 8 | import Data.List.NonEmpty (NonEmpty((:|))) 9 | import qualified Data.Map as Map 10 | import Data.Maybe (fromJust, catMaybes) 11 | import Data.Monoid ((<>)) 12 | import Data.Vector.Sized (Vector) 13 | import qualified Data.Vector.Sized as V 14 | import Data.Text (Text) 15 | import qualified Data.Text as T 16 | import Reflex 17 | 18 | import Network.Protocol.Minecraft.Packet 19 | import Network.Protocol.Minecraft.Types 20 | 21 | import Inventory 22 | import ItemLookup 23 | 24 | declareFields [d| 25 | data ChatMsg = ChatMsg { chatMsgSender :: Text 26 | , chatMsgMessage :: Text 27 | } deriving (Show) 28 | 29 | data ChatCommand = ChatCommand { chatCommandSender :: Text 30 | , chatCommandCommand :: Text 31 | , chatCommandArguments :: [Text] 32 | } deriving (Show) 33 | |] 34 | 35 | filterCommand :: Reflex t => Text -> Event t ChatCommand -> Event t ChatCommand 36 | filterCommand needle = ffilter ((==needle) . view command) 37 | 38 | checkArguments :: Reflex t => [Int] -> Text -> Event t ChatCommand -> Event t Text 39 | checkArguments lens mes = fmapMaybe $ \cmd -> if length (cmd ^. arguments) `notElem` lens 40 | then Just mes 41 | else Nothing 42 | 43 | helpText :: NonEmpty Text 44 | helpText = "Hi! I'm a bot written by Xandaros and am currently under active development." 45 | :| [ "Available commands are:" 46 | , "help, ping, quit, tp, where, inventory, drop, dimension" 47 | -- , "To get more information about a specific command, use \"help \"" 48 | ] 49 | 50 | commandMessagesE :: Reflex t => Event t ChatCommand -> Event t (NonEmpty Text) 51 | commandMessagesE cmd = 52 | let a = mergeList 53 | [ checkArguments [3,5] "Invalid arguments. tp [ ]" (filterCommand "tp" cmd) 54 | , checkArguments [1,2] "Invalid arguments. drop [amount]" (filterCommand "drop" cmd) 55 | , "Pong!" <$ filterCommand "ping" cmd 56 | , "Bye :'(" <$ filterCommand "quit" cmd 57 | ] 58 | b = helpText <$ filterCommand "help" cmd 59 | in a <> b 60 | 61 | tpCommandE :: Reflex t => Event t ChatCommand -> Event t (Double, Double, Double) 62 | tpCommandE cmd = fforMaybe (filterCommand "tp" cmd) $ \c -> 63 | let args = c ^. arguments 64 | getArg n = read $ T.unpack (args !! n) 65 | x = getArg 0 66 | y = getArg 1 67 | z = getArg 2 68 | in if | length args == 3 -> Just $ (x, y, z) 69 | | length args == 5 -> Just $ (x, y, z) 70 | | otherwise -> Nothing 71 | 72 | quitCommandE :: Reflex t => Event t ChatCommand -> Event t () 73 | quitCommandE = (() <$) . filterCommand "quit" 74 | 75 | whereCommandE :: Reflex t => Event t ChatCommand -> Dynamic t (Double, Double, Double) -> Event t SBPacket 76 | whereCommandE cmd pos = chatString . show <$> 77 | tag (current pos) (filterCommand "where" cmd) 78 | 79 | inventoryCommandE :: forall t. Reflex t => Event t ChatCommand -> Dynamic t (Vector 46 Slot) -> Event t SBPacket 80 | inventoryCommandE cmd inventory = chatString . renderSlots <$> inventoryEvents 81 | where prettySlot :: (Int, Maybe String) -> Maybe String 82 | prettySlot (_, Nothing) = Nothing 83 | prettySlot (slot, Just slotData) = Just $ slotData ++ "(" ++ show slot ++ ")" 84 | 85 | inventoryEvents :: Event t (Vector 46 Slot) 86 | inventoryEvents = tag (current inventory) (filterCommand "inventory" cmd) 87 | 88 | zipped :: Vector 46 Slot -> Vector 46 (Int, Slot) 89 | zipped = V.zip (fromJust $ V.fromListN [0..]) 90 | 91 | renderSlots :: Vector 46 Slot -> String 92 | renderSlots = concat . intersperse ", " . catMaybes . fmap (prettySlot . fmap printSlot) . V.toList . zipped 93 | 94 | dropCommandE :: Reflex t => Event t ChatCommand -> Event t InventoryAction 95 | dropCommandE cmd = fforMaybe (filterCommand "drop" cmd) $ \c -> 96 | let args = c ^. arguments 97 | getArg n = read $ T.unpack (args !! n) 98 | slot = getArg 0 99 | --amount = getArg 1 100 | in if | length args == 1 -> Just $ DropStack 0 slot 101 | | otherwise -> Nothing 102 | 103 | chatString :: String -> SBPacket 104 | chatString = SBChatMessage . SBChatMessagePayload . view network . T.pack . take 256 105 | 106 | printSlot :: Slot -> Maybe String 107 | printSlot (Slot (-1) _ _) = Nothing 108 | printSlot (Slot bid count dmg) = let dmgpart = case dmg of 109 | Just 0 -> "" 110 | Just d -> ":" ++ show d 111 | Nothing -> "" 112 | countpart = case count of 113 | Just c -> show c ++ "x" 114 | Nothing -> "" 115 | itempart = case Map.lookup (fromIntegral bid) itemLookup of 116 | Just name -> name 117 | Nothing -> show bid 118 | in Just $ countpart ++ itempart ++ dmgpart 119 | 120 | dimensionCommandE :: forall t. Reflex t => Event t ChatCommand -> Dynamic t Dimension -> Event t SBPacket 121 | dimensionCommandE cmd dim = chatString . show <$> dimEvents 122 | where dimEvents :: Event t Dimension 123 | dimEvents = tag (current dim) (filterCommand "dimension" cmd) 124 | 125 | closeWindowCommandE :: forall t. Reflex t => Event t ChatCommand -> Dynamic t (Maybe CBOpenWindowPayload) -> Event t SBPacket 126 | closeWindowCommandE cmd window = fforMaybe evs $ \case 127 | Nothing -> Nothing 128 | Just inp -> Just $ SBCloseWindow (SBCloseWindowPayload (inp ^. windowId)) 129 | where evs :: Event t (Maybe CBOpenWindowPayload) 130 | evs = tag (current window) (filterCommand "closewindow" cmd) 131 | 132 | placeBlockCommandE :: forall t. Reflex t => Event t ChatCommand -> Event t SBPacket 133 | placeBlockCommandE cmd = fforMaybe (filterCommand "placeBlock" cmd) $ \c -> 134 | let args = c ^. arguments 135 | getArg n = read $ T.unpack (args !! n) 136 | x = getArg 0 137 | y = getArg 1 138 | z = getArg 2 139 | pos = Position x y z 140 | in if | length args == 3 -> Just $ SBPlayerBlockPlacement (SBPlayerBlockPlacementPayload pos 1 0 0 0 0) 141 | | otherwise -> Nothing 142 | 143 | windowCommandE :: forall t. Reflex t => Event t ChatCommand -> Dynamic t (Maybe CBOpenWindowPayload) -> Event t SBPacket 144 | windowCommandE cmd window = evs <&> \case 145 | Nothing -> chatString "None" 146 | Just w -> chatString (show w) 147 | where evs :: Event t (Maybe CBOpenWindowPayload) 148 | evs = tag (current window) (filterCommand "currentWindow" cmd) 149 | -------------------------------------------------------------------------------- /app/DB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | 11 | module DB ( getProfiles 12 | , newProfile 13 | , deleteProfile 14 | , getProfile 15 | , updateAccessToken 16 | , getClientToken 17 | , getServers 18 | , newServer 19 | , deleteServer 20 | , getServer 21 | , Profile(..) 22 | , profileUsername 23 | , profileUuid 24 | , profileToken 25 | , Server(..) 26 | , serverName 27 | , serverAddress 28 | ) where 29 | import Control.Lens 30 | import Control.Monad (void) 31 | import Control.Monad.IO.Class (liftIO) 32 | import Data.Text (Text) 33 | import qualified Data.UUID as UUID 34 | import qualified Data.UUID.V4 as UUID 35 | import Database.Persist 36 | import Database.Persist.Sqlite 37 | import Database.Persist.TH 38 | 39 | share [ mkPersist sqlSettings {mpsGenerateLenses = True} 40 | , mkMigrate "migrateAll" 41 | ] [persistLowerCase| 42 | Profile 43 | username Text 44 | uuid Text 45 | token Text 46 | UniqueProfileUsername username 47 | deriving Show 48 | KV 49 | key Text 50 | value Text 51 | UniqueKey key 52 | deriving Show 53 | Server 54 | name Text 55 | address Text 56 | UniqueServerName name 57 | deriving Show 58 | |] 59 | 60 | database :: Text 61 | database = "MinecraftCLI.db" 62 | 63 | getClientToken :: IO Text 64 | getClientToken = runSqlite database $ do 65 | runMigration migrateAll 66 | tokenm <- getBy (UniqueKey "clientToken") 67 | case tokenm of 68 | Just token -> pure $ entityVal token ^. kVValue 69 | Nothing -> do 70 | token <- UUID.toText <$> liftIO UUID.nextRandom 71 | _ <- insert (KV "clientToken" token) 72 | pure token 73 | 74 | getProfiles :: IO [Profile] 75 | getProfiles = runSqlite database $ do 76 | runMigration migrateAll 77 | fmap entityVal <$> selectList [] [] 78 | 79 | newProfile :: Profile -> IO () 80 | newProfile prof = runSqlite database $ do 81 | runMigration migrateAll 82 | void $ insert prof 83 | 84 | deleteProfile :: Text -> IO () 85 | deleteProfile username = runSqlite database $ do 86 | runMigration migrateAll 87 | deleteBy (UniqueProfileUsername username) 88 | 89 | getProfile :: Text -> IO (Maybe Profile) 90 | getProfile username = runSqlite database $ do 91 | runMigration migrateAll 92 | fmap entityVal <$> getBy (UniqueProfileUsername username) 93 | 94 | updateAccessToken :: Text -> Text -> IO () 95 | updateAccessToken username accessToken = runSqlite database $ do 96 | runMigration migrateAll 97 | updateWhere [ProfileUsername ==. username] [ProfileToken =. accessToken] 98 | 99 | getServers :: IO [Server] 100 | getServers = runSqlite database $ do 101 | runMigration migrateAll 102 | fmap entityVal <$> selectList [] [] 103 | 104 | newServer :: Server -> IO () 105 | newServer server = runSqlite database $ do 106 | runMigration migrateAll 107 | void $ insert server 108 | 109 | deleteServer :: Text -> IO () 110 | deleteServer name = runSqlite database $ do 111 | runMigration migrateAll 112 | deleteBy (UniqueServerName name) 113 | 114 | getServer :: Text -> IO (Maybe Server) 115 | getServer name = runSqlite database $ do 116 | runMigration migrateAll 117 | fmap entityVal <$> getBy (UniqueServerName name) 118 | -------------------------------------------------------------------------------- /app/Inventory.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, ViewPatterns, LambdaCase #-} 2 | module Inventory where 3 | 4 | import Control.Lens 5 | import Control.Monad.Fix (MonadFix) 6 | import Data.Finite 7 | import Data.Int 8 | import Data.List.NonEmpty (NonEmpty) 9 | import Data.Map (Map) 10 | import qualified Data.Map as Map 11 | import Data.Maybe (catMaybes) 12 | import Data.Vector.Sized (Vector) 13 | import qualified Data.Vector.Sized as V 14 | import Reflex 15 | 16 | import Network.Protocol.Minecraft.Packet 17 | import Network.Protocol.Minecraft.Types 18 | 19 | data InventoryAction = SetSlot Integer Integer Slot 20 | | DropStack Integer Integer 21 | deriving (Show) 22 | 23 | inventoryD :: (Reflex t, MonadHold t m, MonadFix m) 24 | => Event t InventoryAction -> m (Dynamic t (Vector 46 Slot)) 25 | inventoryD action = foldDynMaybe foldFun (V.replicate emptySlot) action 26 | where foldFun :: InventoryAction -> V.Vector 46 Slot -> Maybe (Vector 46 Slot) 27 | foldFun act inv = case act of 28 | SetSlot 0 slot slotData -> do 29 | slot' <- packFinite slot 30 | pure $ inv & V.ix slot' .~ slotData 31 | DropStack 0 slot -> do 32 | slot' <- packFinite slot 33 | pure $ inv & V.ix slot' .~ emptySlot 34 | _ -> Nothing 35 | 36 | cbInventoryActionsE :: Reflex t => Event t CBPacket -> Event t InventoryAction 37 | cbInventoryActionsE = fmapMaybe $ \case 38 | CBSetSlot (CBSetSlotPayload (fromIntegral -> wid) (fromIntegral -> slot) slotData) -> 39 | Just $ SetSlot wid slot slotData 40 | _ -> Nothing 41 | 42 | data InventoryMap = InventoryMap { inventoryMapNext :: Int16 43 | , inventoryMapMap :: Map Int16 InventoryAction 44 | } 45 | 46 | inventoryMapEmpty :: InventoryMap 47 | inventoryMapEmpty = InventoryMap 0 Map.empty 48 | 49 | inventoryMapInsert :: InventoryAction -> InventoryMap -> InventoryMap 50 | inventoryMapInsert action (InventoryMap next map) = InventoryMap (next+1) (Map.insert next action map) 51 | 52 | inventoryMapDelete :: Int16 -> InventoryMap -> InventoryMap 53 | inventoryMapDelete id (InventoryMap next map) = InventoryMap next (Map.delete id map) 54 | 55 | transactionsD :: (Reflex t, MonadHold t m, MonadFix m) 56 | => Event t (NonEmpty InventoryAction) 57 | -> Event t Int16 58 | -> m (Event t [SBPacket], Event t InventoryAction) 59 | transactionsD actions confirmations = do 60 | let additions = foldr1 (.) . fmap inventoryMapInsert <$> actions 61 | deletions = inventoryMapDelete <$> confirmations 62 | mapActions = mergeWith (.) [additions, deletions] 63 | addedTransactions = ($ inventoryMapEmpty) <$> additions 64 | transactions <- fmap inventoryMapMap <$> foldDyn id inventoryMapEmpty mapActions 65 | let localInventoryAction = attachWithMaybe (flip Map.lookup) (current transactions) confirmations 66 | pure (transactionPacketsE addedTransactions, localInventoryAction) 67 | 68 | 69 | transactionPacketsE :: Reflex t => Event t InventoryMap -> Event t [SBPacket] 70 | transactionPacketsE actions = ffor actions $ catMaybes . fmap mkPacket . Map.toList . inventoryMapMap 71 | where mkPacket :: (Int16, InventoryAction) -> Maybe SBPacket 72 | mkPacket (tnum, action) = case action of 73 | SetSlot _ _ _ -> Nothing 74 | DropStack (fromIntegral -> wid) (fromIntegral -> slot) -> 75 | Just $ SBClickWindow (SBClickWindowPayload wid slot 1 tnum 4 (Slot (-1) Nothing Nothing)) 76 | 77 | transactionConfirmationsE :: Reflex t => Event t CBPacket -> Event t Int16 78 | transactionConfirmationsE inbound = fforMaybe inbound $ \case 79 | CBConfirmTransaction (CBConfirmTransactionPayload 0 i True) -> Just i 80 | _ -> Nothing 81 | -------------------------------------------------------------------------------- /app/ItemLookup.hs: -------------------------------------------------------------------------------- 1 | module ItemLookup where 2 | 3 | import qualified Data.Map as Map 4 | import Data.Map (Map) 5 | 6 | itemLookup :: Map Int String 7 | itemLookup = Map.fromList 8 | [ (0, "Air") 9 | , (1, "Stone") 10 | , (2, "Grass Block") 11 | , (3, "Dirt") 12 | , (4, "Cobblestone") 13 | , (5, "Wood Planks") 14 | , (6, "Sapling") 15 | , (7, "Bedrock") 16 | , (8, "Water") 17 | , (9, "Water") 18 | , (10, "Lava") 19 | , (11, "Lava") 20 | , (12, "Sand") 21 | , (13, "Gravel") 22 | , (14, "Gold Ore") 23 | , (15, "Iron Ore") 24 | , (16, "Coal Ore") 25 | , (17, "Wood") 26 | , (18, "Leaves") 27 | , (19, "Sponge") 28 | , (20, "Glass") 29 | , (21, "Lapis Lazuli Ore") 30 | , (22, "Lapis Lazuli Block") 31 | , (23, "Dispenser") 32 | , (24, "Sandstone") 33 | , (25, "Note Block") 34 | , (26, "Bed") 35 | , (27, "Powered Rail") 36 | , (28, "Detector Rail") 37 | , (29, "Sticky Piston") 38 | , (30, "Cobweb") 39 | , (31, "Grass") 40 | , (32, "Dead Bush") 41 | , (33, "Piston") 42 | , (34, "Piston Head") 43 | , (35, "Wool") 44 | , (36, "Block moved by Piston") 45 | , (37, "Dandelion") 46 | , (38, "Poppy") 47 | , (39, "Brown Mushroom") 48 | , (40, "Red Mushroom") 49 | , (41, "Block of Gold") 50 | , (42, "Block of Iron") 51 | , (43, "Double Stone Slab") 52 | , (44, "Stone Slab") 53 | , (45, "Bricks") 54 | , (46, "TNT") 55 | , (47, "Bookshelf") 56 | , (48, "Moss Stone") 57 | , (49, "Obsidian") 58 | , (50, "Torch") 59 | , (51, "Fire") 60 | , (52, "Monster Spawner") 61 | , (53, "Oak Wood Stairs") 62 | , (54, "Chest") 63 | , (55, "Redstone Wire") 64 | , (56, "Diamond Ore") 65 | , (57, "Block of Diamond") 66 | , (58, "Crafting Table") 67 | , (59, "Wheat") 68 | , (60, "Farmland") 69 | , (61, "Furnace") 70 | , (62, "Burning Furnace") 71 | , (63, "Sign") 72 | , (64, "Oak Door") 73 | , (65, "Ladder") 74 | , (66, "Rail") 75 | , (67, "Cobblestone Stairs") 76 | , (68, "Sign") 77 | , (69, "Lever") 78 | , (70, "Stone Pressure Plate") 79 | , (71, "Iron Door") 80 | , (72, "Wooden Pressure Plate") 81 | , (73, "Redstone Ore") 82 | , (74, "Redstone Ore") 83 | , (75, "Redstone Torch (inactive)") 84 | , (76, "Redstone Torch (active)") 85 | , (77, "Stone Button") 86 | , (78, "Snow (layer)") 87 | , (79, "Ice") 88 | , (80, "Snow") 89 | , (81, "Cactus") 90 | , (82, "Clay") 91 | , (83, "Sugar Cane") 92 | , (84, "Jukebox") 93 | , (85, "Oak Fence") 94 | , (86, "Pumpkin") 95 | , (87, "Netherrack") 96 | , (88, "Soul Sand") 97 | , (89, "Glowstone") 98 | , (90, "Portal") 99 | , (91, "Jack o'Lantern") 100 | , (92, "Cake") 101 | , (93, "Redstone Repeater (inactive)") 102 | , (94, "Redstone Repeater (active)") 103 | , (95, "Stained Glass") 104 | , (96, "Trapdoor") 105 | , (97, "Monster Egg") 106 | , (98, "Stone Bricks") 107 | , (99, "Brown Mushroom (block)") 108 | , (100, "Red Mushroom (block)") 109 | , (101, "Iron Bars") 110 | , (102, "Glass Pane") 111 | , (103, "Melon") 112 | , (104, "Pumpkin Stem") 113 | , (105, "Melon Stem") 114 | , (106, "Vines") 115 | , (107, "Fence Gate") 116 | , (108, "Brick Stairs") 117 | , (109, "Stone Brick Stairs") 118 | , (110, "Mycelium") 119 | , (111, "Lily Pad") 120 | , (112, "Nether Brick") 121 | , (113, "Nether Brick Fence") 122 | , (114, "Nether Brick Stairs") 123 | , (115, "Nether Wart") 124 | , (116, "Enchantment Table") 125 | , (117, "Brewing Stand") 126 | , (118, "Cauldron") 127 | , (119, "End Portal") 128 | , (120, "End Portal Frame") 129 | , (121, "End Stone") 130 | , (122, "Dragon Egg") 131 | , (123, "Redstone Lamp (inactive)") 132 | , (124, "Redstone Lamp (active)") 133 | , (125, "Double Wooden Slab") 134 | , (126, "Wooden Slab") 135 | , (127, "Cocoa") 136 | , (128, "Sandstone Stairs") 137 | , (129, "Emerald Ore") 138 | , (130, "Ender Chest") 139 | , (131, "Tripwire Hook") 140 | , (132, "Tripwire") 141 | , (133, "Block of Emerald") 142 | , (134, "Spruce Wood Stairs") 143 | , (135, "Birch Wood Stairs") 144 | , (136, "Jungle Wood Stairs") 145 | , (137, "Command Block") 146 | , (138, "Beacon") 147 | , (139, "Cobblestone Wall") 148 | , (140, "Flower Pot") 149 | , (141, "Carrot") 150 | , (142, "Potato") 151 | , (143, "Wooden Button") 152 | , (144, "Mob head") 153 | , (145, "Anvil") 154 | , (146, "Trapped Chest") 155 | , (147, "Weighted Pressure Plate (Light)") 156 | , (148, "Weighted Pressure Plate (Heavy)") 157 | , (149, "Redstone Comparator") 158 | , (150, "Redstone Comparator (deprecated)") 159 | , (151, "Daylight Sensor") 160 | , (152, "Block of Redstone") 161 | , (153, "Nether Quartz Ore") 162 | , (154, "Hopper") 163 | , (155, "Block of Quartz") 164 | , (156, "Quartz Stairs") 165 | , (157, "Activator Rail") 166 | , (158, "Dropper") 167 | , (159, "Stained Clay") 168 | , (160, "Stained Glass Pane") 169 | , (161, "Leaves (Acacia/Dark Oak)") 170 | , (162, "Wood (Acacia/Dark Oak)") 171 | , (163, "Acacia Wood Stairs") 172 | , (164, "Dark Oak Wood Stairs") 173 | , (165, "Slime Block") 174 | , (166, "Barrier") 175 | , (167, "Iron Trapdoor") 176 | , (168, "Prismarine") 177 | , (169, "Sea Lantern") 178 | , (170, "Hay Bale") 179 | , (171, "Carpet") 180 | , (172, "Hardened Clay") 181 | , (173, "Block of Coal") 182 | , (174, "Packed Ice") 183 | , (175, "Large Flowers") 184 | , (176, "Banner") 185 | , (177, "Banner") 186 | , (178, "Inverted Daylight Sensor") 187 | , (179, "Red Sandstone") 188 | , (180, "Red Sandstone Stairs") 189 | , (181, "Double Red Sandstone Slab") 190 | , (182, "Red Sandstone Slab") 191 | , (183, "Spruce Fence Gate") 192 | , (184, "Birch Fence Gate") 193 | , (185, "Jungle Fence Gate") 194 | , (186, "Dark Oak Fence Gate") 195 | , (187, "Acacia Fence Gate") 196 | , (188, "Spruce Fence") 197 | , (189, "Birch Fence") 198 | , (190, "Jungle Fence") 199 | , (191, "Dark Oak Fence") 200 | , (192, "Acacia Fence") 201 | , (193, "Spruce Door") 202 | , (194, "Birch Door") 203 | , (195, "Jungle Door") 204 | , (196, "Acacia Door") 205 | , (197, "Dark Oak Door") 206 | , (198, "End Rod") 207 | , (199, "Chorus Plant") 208 | , (200, "Chorus Flower") 209 | , (201, "Purpur Block") 210 | , (202, "Purpur Pillar") 211 | , (203, "Purpur Stairs") 212 | , (204, "Purpur Double Slab") 213 | , (205, "Purpur Slab") 214 | , (206, "End Stone Bricks") 215 | , (207, "Beetroot Seeds") 216 | , (208, "Grass Path") 217 | , (209, "End Gateway") 218 | , (210, "Repeating Command Block") 219 | , (211, "Chain Command Block") 220 | , (212, "Frosted Ice") 221 | , (213, "Magma Block") 222 | , (214, "Nether Wart Block") 223 | , (215, "Red Nether Brick") 224 | , (216, "Bone Block") 225 | , (217, "Structure Void") 226 | , (218, "Observer") 227 | , (219, "White Shulker Box") 228 | , (220, "Orange Shulker Box") 229 | , (221, "Magenta Shulker Box") 230 | , (222, "Light Blue Shulker Box") 231 | , (223, "Yellow Shulker Box") 232 | , (224, "Lime Shulker Box") 233 | , (225, "Pink Shulker Box") 234 | , (226, "Gray Shulker Box") 235 | , (227, "Light Gray Shulker Box") 236 | , (228, "Cyan Shulker Box") 237 | , (229, "Purple Shulker Box") 238 | , (230, "Blue Shulker Box") 239 | , (231, "Brown Shulker Box") 240 | , (232, "Green Shulker Box") 241 | , (233, "Red Shulker Box") 242 | , (234, "Black Shulker Box") 243 | , (235, "White Glazed Terracotta") 244 | , (236, "Orange Glazed Terracotta") 245 | , (237, "Magenta Glazed Terracotta") 246 | , (238, "Light Blue Glazed Terracotta") 247 | , (239, "Yellow Glazed Terracotta") 248 | , (240, "Lime Glazed Terracotta") 249 | , (241, "Pink Glazed Terracotta") 250 | , (242, "Gray Glazed Terracotta") 251 | , (243, "Light Gray Glazed Terracotta") 252 | , (244, "Cyan Glazed Terracotta") 253 | , (245, "Purple Glazed Terracotta") 254 | , (246, "Blue Glazed Terracotta") 255 | , (247, "Brown Glazed Terracotta") 256 | , (248, "Green Glazed Terracotta") 257 | , (249, "Red Glazed Terracotta") 258 | , (250, "Black Glazed Terracotta") 259 | , (251, "Concrete") 260 | , (252, "Concrete Powder") 261 | 262 | 263 | , (255, "Structure Block") 264 | , (256, "Iron Shovel") 265 | , (257, "Iron Pickaxe") 266 | , (258, "Iron Axe") 267 | , (259, "Flint and Steel") 268 | , (260, "Apple") 269 | , (261, "Bow") 270 | , (262, "Arrow") 271 | , (263, "Coal") 272 | , (264, "Diamond") 273 | , (265, "Iron Ingot") 274 | , (266, "Gold Ingot") 275 | , (267, "Iron Sword") 276 | , (268, "Wooden Sword") 277 | , (269, "Wooden Shovel") 278 | , (270, "Wooden Pickaxe") 279 | , (271, "Wooden Axe") 280 | , (272, "Stone Sword") 281 | , (273, "Stone Shovel") 282 | , (274, "Stone Pickaxe") 283 | , (275, "Stone Axe") 284 | , (276, "Diamond Sword") 285 | , (277, "Diamond Shovel") 286 | , (278, "Diamond Pickaxe") 287 | , (279, "Diamond Axe") 288 | , (280, "Stick") 289 | , (281, "Bowl") 290 | , (282, "Mushroom Stew") 291 | , (283, "Golden Sword") 292 | , (284, "Golden Shovel") 293 | , (285, "Golden Pickaxe") 294 | , (286, "Golden Axe") 295 | , (287, "String") 296 | , (288, "Feather") 297 | , (289, "Gunpowder") 298 | , (290, "Wooden Hoe") 299 | , (291, "Stone Hoe") 300 | , (292, "Iron Hoe") 301 | , (293, "Diamond Hoe") 302 | , (294, "Golden Hoe") 303 | , (295, "Seeds") 304 | , (296, "Wheat") 305 | , (297, "Bread") 306 | , (298, "Leather Cap") 307 | , (299, "Leather Tunic") 308 | , (300, "Leather Pants") 309 | , (301, "Leather Boots") 310 | , (302, "Chain Helmet") 311 | , (303, "Chain Chestplate") 312 | , (304, "Chain Leggings") 313 | , (305, "Chain Boots") 314 | , (306, "Iron Helmet") 315 | , (307, "Iron Chestplate") 316 | , (308, "Iron Leggings") 317 | , (309, "Iron Boots") 318 | , (310, "Diamond Helmet") 319 | , (311, "Diamond Chestplate") 320 | , (312, "Diamond Leggings") 321 | , (313, "Diamond Boots") 322 | , (314, "Golden Helmet") 323 | , (315, "Golden Chestplate") 324 | , (316, "Golden Leggings") 325 | , (317, "Golden Boots") 326 | , (318, "Flint") 327 | , (319, "Raw Porkchop") 328 | , (320, "Cooked Porkchop") 329 | , (321, "Painting") 330 | , (322, "Golden Apple") 331 | , (323, "Sign") 332 | , (324, "Oak Door") 333 | , (325, "Bucket") 334 | , (326, "Water Bucket") 335 | , (327, "Lava Bucket") 336 | , (328, "Minecart") 337 | , (329, "Saddle") 338 | , (330, "Iron Door") 339 | , (331, "Redstone") 340 | , (332, "Snowball") 341 | , (333, "Boat") 342 | , (334, "Leather") 343 | , (335, "Milk") 344 | , (336, "Brick") 345 | , (337, "Clay") 346 | , (338, "Sugar Cane") 347 | , (339, "Paper") 348 | , (340, "Book") 349 | , (341, "Slimeball") 350 | , (342, "Minecart with Chest") 351 | , (343, "Minecart with Furnace") 352 | , (344, "Egg") 353 | , (345, "Compass") 354 | , (346, "Fishing Rod") 355 | , (347, "Clock") 356 | , (348, "Glowstone Dust") 357 | , (349, "Raw Fish") 358 | , (350, "Cooked Fish") 359 | , (351, "Dye") 360 | , (352, "Bone") 361 | , (353, "Sugar") 362 | , (354, "Cake") 363 | , (355, "Bed") 364 | , (356, "Redstone Repeater") 365 | , (357, "Cookie") 366 | , (358, "Map") 367 | , (359, "Shears") 368 | , (360, "Melon") 369 | , (361, "Pumpkin Seeds") 370 | , (362, "Melon Seeds") 371 | , (363, "Raw Beef") 372 | , (364, "Steak") 373 | , (365, "Raw Chicken") 374 | , (366, "Cooked Chicken") 375 | , (367, "Rotten Flesh") 376 | , (368, "Ender Pearl") 377 | , (369, "Blaze Rod") 378 | , (370, "Ghast Tear") 379 | , (371, "Gold Nugget") 380 | , (372, "Nether Wart") 381 | , (373, "Potion") 382 | , (374, "Glass Bottle") 383 | , (375, "Spider Eye") 384 | , (376, "Fermented Spider Eye") 385 | , (377, "Blaze Powder") 386 | , (378, "Magma Cream") 387 | , (379, "Brewing Stand") 388 | , (380, "Cauldron") 389 | , (381, "Eye of Ender") 390 | , (382, "Glistering Melon") 391 | , (383, "Spawn Egg") 392 | , (384, "Bottle o' Enchanting") 393 | , (385, "Fire Charge") 394 | , (386, "Book and Quill") 395 | , (387, "Written Book") 396 | , (388, "Emerald") 397 | , (389, "Item Frame") 398 | , (390, "Flower Pot") 399 | , (391, "Carrot") 400 | , (392, "Potato") 401 | , (393, "Baked Potato") 402 | , (394, "Poisonous Potato") 403 | , (395, "Empty Map") 404 | , (396, "Golden Carrot") 405 | , (397, "Mob head") 406 | , (398, "Carrot on a Stick") 407 | , (399, "Nether Star") 408 | , (400, "Pumpkin Pie") 409 | , (401, "Firework Rocket") 410 | , (402, "Firework Star") 411 | , (403, "Enchanted Book") 412 | , (404, "Redstone Comparator") 413 | , (405, "Nether Brick") 414 | , (406, "Nether Quartz") 415 | , (407, "Minecart with TNT") 416 | , (408, "Minecart with Hopper") 417 | , (409, "Prismarine Shard") 418 | , (410, "Prismarine Crystals") 419 | , (411, "Raw Rabbit") 420 | , (412, "Cooked Rabbit") 421 | , (413, "Rabbit Stew") 422 | , (414, "Rabbit's Foot") 423 | , (415, "Rabbit Hide") 424 | , (416, "Armor Stand") 425 | , (417, "Iron Horse Armor") 426 | , (418, "Golden Horse Armor") 427 | , (419, "Diamond Horse Armor") 428 | , (420, "Lead") 429 | , (421, "Name Tag") 430 | , (422, "Minecart with Command Block") 431 | , (423, "Raw Mutton") 432 | , (424, "Cooked Mutton") 433 | , (425, "Banner") 434 | , (426, "End Crystal") 435 | , (427, "Spruce Door") 436 | , (428, "Birch Door") 437 | , (429, "Jungle Door") 438 | , (430, "Acacia Door") 439 | , (431, "Dark Oak Door") 440 | , (432, "Chorus Fruit") 441 | , (433, "Popped Chorus Fruit") 442 | , (434, "Beetroot") 443 | , (435, "Beetroot Seeds") 444 | , (436, "Beetroot Soup") 445 | , (437, "Dragon's Breath") 446 | , (438, "Splash Potion") 447 | , (439, "Spectral Arrow") 448 | , (440, "Tipped Arrow") 449 | , (441, "Lingering Potion") 450 | , (442, "Shield") 451 | , (443, "Elytra") 452 | , (444, "Spruce Boat") 453 | , (445, "Birch Boat") 454 | , (446, "Jungle Boat") 455 | , (447, "Acacia Boat") 456 | , (448, "Dark Oak Boat") 457 | , (449, "Totem of Undying") 458 | , (450, "Shulker Shell") 459 | 460 | , (452, "Iron Nugget") 461 | 462 | 463 | 464 | 465 | 466 | 467 | , (2256, "13 Disc") 468 | , (2257, "Cat Disc") 469 | , (2258, "Blocks Disc") 470 | , (2259, "Chirp Disc") 471 | , (2260, "Far Disc") 472 | , (2261, "Mall Disc") 473 | , (2262, "Mellohi Disc") 474 | , (2263, "Stal Disc") 475 | , (2264, "Strad Disc") 476 | , (2265, "Ward Disc") 477 | , (2266, "11 Disc") 478 | , (2267, "Wait Disc") 479 | ] 480 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, OverloadedStrings, TupleSections, Arrows, ViewPatterns, QuasiQuotes, TemplateHaskell #-} 2 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies #-} 3 | {-# LANGUAGE LambdaCase, MultiWayIf, RecursiveDo #-} 4 | module Main where 5 | 6 | import Data.Aeson 7 | import qualified Data.ByteString.Lazy as BSL 8 | import qualified Data.List.NonEmpty as NE 9 | import Data.List.NonEmpty (NonEmpty) 10 | import Data.List.Split (splitOn) 11 | import Data.Monoid ((<>)) 12 | import Control.Concurrent (threadDelay, forkIO) 13 | import Control.Concurrent.Async 14 | import Control.Concurrent.STM 15 | import Control.Lens 16 | import Control.Monad (void, when, forever, forM_) 17 | import Control.Monad.Fix (MonadFix) 18 | import Control.Monad.IO.Class 19 | import Data.Int 20 | import Data.IORef 21 | import Data.List (isPrefixOf) 22 | import qualified Data.Text as T 23 | import Data.Text (Text) 24 | import qualified Data.Text.Encoding as TE 25 | import Safe 26 | import System.Console.Haskeline 27 | import System.Console.Haskeline.Completion 28 | import System.Exit (exitSuccess) 29 | import Reflex hiding (performEvent_) 30 | import Reflex.Host.App 31 | 32 | import Network.Protocol.Minecraft 33 | import Network.Protocol.Minecraft.Packet 34 | import Network.Protocol.Minecraft.Types 35 | import qualified Network.Protocol.Minecraft.Yggdrasil as Yggdrasil 36 | import Network.Protocol.Minecraft.Yggdrasil () 37 | 38 | import Commands 39 | import DB ( Profile(..), profileUsername, profileUuid, profileToken 40 | , Server(..), serverName, serverAddress 41 | ) 42 | import qualified DB 43 | import Inventory 44 | 45 | import Debug.Trace 46 | 47 | minecraftThread :: TChan CBPacket -> TChan [SBPacket] -> IORef Bool -> Profile -> Server -> (String -> IO ()) -> IO () 48 | minecraftThread inbound outbound shutdown profile server printfunc = do 49 | let addr = takeWhile (/= ':') . T.unpack $ server ^. serverAddress 50 | port = readMay $ drop 1 . dropWhile (/= ':') . T.unpack $ server ^. serverAddress 51 | void $ connect addr port $ do 52 | liftIO $ printfunc "Sending handshake" 53 | handshake 54 | liftIO $ printfunc "Handshake sent" 55 | 56 | loginSucc <- login (profile ^. profileUsername) (profile ^. profileUuid) (profile ^. profileToken) 57 | 58 | case loginSucc of 59 | Left err -> liftIO $ putStrLn err 60 | Right _ -> liftIO $ do 61 | printfunc "Logged in" 62 | 63 | sendPacket $ SBClientSettingsPayload "en_GB" 1 0 True 0x7F 1 64 | sendPacket $ SBClientStatusPayload 0 65 | sendPacket $ SBChatMessage $ SBChatMessagePayload ("Beep. Boop. I'm a bot. Type \"" <> profile ^. profileUsername . network <> ": help\" for more information") 66 | sendPacket $ SBChatMessagePayload "/afk" 67 | 68 | whileM (liftIO $ not <$> readIORef shutdown) $ do 69 | packetAvailable <- hasPacket 70 | when packetAvailable $ do 71 | packet' <- receivePacket 72 | 73 | case packet' of 74 | Just packet -> case packet of 75 | CBKeepAlive keepAlive -> do 76 | let response = SBKeepAlivePayload $ keepAlive ^. keepAliveId 77 | sendPacket response 78 | CBPlayerPositionAndLook positionAndLook -> do 79 | liftIO $ printfunc "Position and look" 80 | sendPacket $ SBTeleportConfirmPayload $ positionAndLook ^. posLookID 81 | sendPacket $ SBPlayerPositionAndLookPayload (positionAndLook^.x) (positionAndLook^.y) (positionAndLook^.z) (positionAndLook^.yaw) (positionAndLook^.pitch) True 82 | liftIO . atomically $ writeTChan inbound packet 83 | CBDisconnectPlay dc -> do 84 | liftIO $ printfunc $ "Disconnected: " ++ T.unpack (dc ^. reason . from network) 85 | _ -> liftIO . atomically $ writeTChan inbound packet 86 | Nothing -> liftIO $ do 87 | writeIORef shutdown True 88 | printfunc "Connection closed" >> exitSuccess 89 | dataToSend <- liftIO . atomically $ tryReadTChan outbound 90 | case dataToSend of 91 | Just dataToSend -> sequence_ $ sendPacket <$> dataToSend 92 | Nothing -> pure () 93 | liftIO $ when (not packetAvailable) $ do 94 | threadDelay (floor $ ((1/21) :: Double) * 1000000) 95 | 96 | 97 | frpThread :: TChan CBPacket -> TChan [SBPacket] -> IORef Bool -> Profile -> (String -> IO ()) -> IO () 98 | frpThread inbound outbound shutdown profile printfunc = runSpiderHost $ hostApp app 99 | where app :: MonadAppHost t m => m () 100 | app = do 101 | (inputEvent, inputFire) <- newExternalEvent 102 | (tickEvent, tickFire) <- newExternalEvent 103 | void . liftIO . forkIO . forever $ threadDelay (floor (1/20 * 1000000 :: Double)) >>= tickFire 104 | void . liftIO . forkIO . forever $ atomically (readTChan inbound) >>= inputFire 105 | (outEvent, printEvent, shutdownEvent) <- minecraftBot (profile ^. profileUsername) inputEvent tickEvent 106 | performEvent_ $ fmap (liftIO . atomically . writeTChan outbound) outEvent 107 | performEvent_ $ fmap (sequence_ . fmap liftIO . fmap (printfunc . T.unpack) . NE.toList) printEvent 108 | performEvent_ $ fmap (const . liftIO $ threadDelay 10000 >> writeIORef shutdown True) shutdownEvent 109 | pure () 110 | 111 | minecraftBot :: (MonadHold t m, MonadFix m, Reflex t) => Text -> Event t CBPacket -> Event t () 112 | -> m (Event t [SBPacket], Event t (NonEmpty Text), Event t ()) 113 | minecraftBot botName inbound tick = do 114 | let chatMessages = chatMessageE inbound 115 | commands = commandE botName chatMessages 116 | -- ticks <- zipListWithEvent (\a _ -> a) [1..] tick 117 | -- seconds <- zipListWithEvent (\a _ -> a) ([1..] :: [Integer]) $ ffilter ((==0) . (`mod` (20 :: Integer))) ticks 118 | playerPos <- playerPositionD inbound (tpCommandE commands) 119 | let inventoryActions = mergeList [dropCommandE commands] 120 | (transactionPackets, localInventoryActions) <- transactionsD inventoryActions (transactionConfirmationsE inbound) 121 | inventory <- inventoryD (leftmost $ [(cbInventoryActionsE inbound), localInventoryActions]) 122 | rec currentWindow <- currentWindowD inbound (() <$ windowCloseE) 123 | windowCloseE <- pure $ closeWindowCommandE commands currentWindow 124 | dimension <- dimensionD inbound 125 | pure ( foldl1 (<>) [ NE.toList <$> (fmap (SBChatMessage . SBChatMessagePayload . view network) <$> commandMessagesE commands) 126 | , transactionPackets 127 | , NE.toList <$> (mergeList [ whereCommandE commands playerPos 128 | , mkPPAL <$> tag (current playerPos) tick 129 | , inventoryCommandE commands inventory 130 | , dimensionCommandE commands dimension 131 | , placeBlockCommandE commands 132 | , windowCloseE 133 | , windowCommandE commands currentWindow 134 | --, chatString . show <$> tagPromptlyDyn transactions (ffilter ((==0) . (`mod` 10)) seconds) 135 | ]) 136 | ] 137 | , mergeList [ T.pack . show <$> chatMessages 138 | , T.pack . show <$> commands 139 | , windowItemsE inbound 140 | , T.pack . show <$> transactionConfirmationsE inbound 141 | , T.pack . show <$> placeBlockCommandE commands 142 | ] 143 | , void $ quitCommandE commands 144 | ) 145 | 146 | currentWindowD :: (Reflex t, MonadHold t m) => Event t CBPacket -> Event t () -> m (Dynamic t (Maybe CBOpenWindowPayload)) 147 | currentWindowD inbound close = do 148 | let opens = fforMaybe inbound $ \case 149 | CBOpenWindow pl -> Just $ Just pl 150 | CBCloseWindow _ -> Just Nothing 151 | _ -> Nothing 152 | closes = Nothing <$ close 153 | evs = leftmost [closes, opens] 154 | holdDyn Nothing evs 155 | 156 | windowItemsE :: Reflex t => Event t CBPacket -> Event t Text 157 | windowItemsE inbound = fforMaybe inbound $ \case 158 | CBWindowItems (CBWindowItemsPayload wid slot) -> Just $ T.pack $ "WindowItems " <> show (wid, slot) 159 | CBSetSlot (CBSetSlotPayload wid slot slotData) -> Just $ T.pack $ "SetSlot " <> show (wid, slot, slotData) 160 | _ -> Nothing 161 | 162 | playerPositionD :: (MonadHold t m, Reflex t) 163 | => Event t CBPacket 164 | -> Event t (Double, Double, Double) 165 | -> m (Dynamic t (Double, Double, Double)) 166 | playerPositionD inbound tp = do 167 | let inboundUpdate = fforMaybe inbound $ \case 168 | CBPlayerPositionAndLook (CBPlayerPositionAndLookPayload x y z _yaw _pitch _flags _) -> 169 | Just (x ^. from network, y ^. from network, z ^. from network) 170 | _ -> Nothing 171 | holdDyn (0, 0, 0) $ leftmost [inboundUpdate, tp] 172 | 173 | dimensionD :: (MonadHold t m, Reflex t) => Event t CBPacket -> m (Dynamic t Dimension) 174 | dimensionD inbound = do 175 | let inboundUpdate = fforMaybe inbound $ \case 176 | CBRespawn (CBRespawnPayload dim _ _ _) -> Just dim 177 | CBJoinGame (CBJoinGamePayload _ _ dim _ _ _ _) -> Just dim 178 | _ -> Nothing 179 | holdDyn Overworld inboundUpdate 180 | 181 | chatMessageE :: Reflex t => Event t CBPacket -> Event t ChatMsg 182 | chatMessageE inbound = fforMaybe inbound $ \case 183 | CBChatMessage (CBChatMessagePayload text _) -> fmap decodeChat . chatToString $ text ^. from network 184 | _ -> Nothing 185 | 186 | commandE :: Reflex t => Text -> Event t ChatMsg -> Event t ChatCommand 187 | commandE botName = fmapMaybe (chatToCommand botName) 188 | 189 | chatToString :: Text -> Maybe String 190 | chatToString c = T.unpack . chatToText . canonicalizeChatComponent <$> decode (BSL.fromStrict $ TE.encodeUtf8 c) 191 | 192 | chatToCommand :: Text -> ChatMsg -> Maybe ChatCommand 193 | chatToCommand botName msg = do 194 | stripped <- T.stripPrefix (botName <> ": ") (msg ^. message) 195 | let split = T.words stripped 196 | cmd <- headMay split 197 | let args = tailSafe split 198 | pure . traceShowId $ ChatCommand (msg ^. sender) cmd args 199 | 200 | decodeChat :: String -> ChatMsg 201 | decodeChat (stripParagraphs -> s) = 202 | let sender = if "<" `isPrefixOf` s 203 | then takeWhile (/='>') . tail $ s 204 | else "" 205 | message = if "<" `isPrefixOf` s 206 | then drop 2 . dropWhile (/='>') $ s 207 | else s 208 | in ChatMsg (T.pack sender) (T.pack message) 209 | 210 | stripParagraphs :: String -> String 211 | stripParagraphs [] = [] 212 | stripParagraphs ('§':_:xs) = stripParagraphs xs 213 | stripParagraphs (x:xs) = x:stripParagraphs xs 214 | 215 | profileInput :: [String] -> InputT IO () 216 | profileInput ("help":_) = do 217 | outputStrLn "Available subcommands:" 218 | outputStrLn "help - Display this help" 219 | outputStrLn "list - List available profiles" 220 | outputStrLn "new - Create a new profile" 221 | outputStrLn "delete - Delete an existing profile" 222 | profileInput ("list":_) = do 223 | profiles <- liftIO DB.getProfiles 224 | forM_ profiles $ \prof -> do 225 | outputStrLn . T.unpack $ prof ^. profileUsername 226 | profileInput ("new":login:_) = do 227 | passwordm <- getPassword Nothing "Password: " 228 | case passwordm of 229 | Nothing -> pure () 230 | Just password -> do 231 | clientToken <- liftIO DB.getClientToken 232 | responsem <- liftIO $ Yggdrasil.authenticate (Yggdrasil.AuthenticationRequest Yggdrasil.defaultAgent 233 | (T.pack login) 234 | (T.pack $ password) 235 | clientToken 236 | False) 237 | case responsem of 238 | Nothing -> outputStrLn "Unable to create profile (wrong login/password?)" 239 | Just response -> do 240 | let profile = response ^. Yggdrasil.selectedProfile 241 | accessToken = response ^. Yggdrasil.accessToken :: Text 242 | liftIO $ DB.newProfile (Profile (profile ^. Yggdrasil.name) (profile ^. Yggdrasil.id) accessToken) 243 | outputStrLn "Profile created" 244 | profileInput ("delete":username:_) = do 245 | liftIO $ DB.deleteProfile (T.pack username) 246 | outputStrLn "Profile deleted" 247 | profileInput _ = profileInput ["help"] 248 | 249 | serverInput :: [String] -> InputT IO () 250 | serverInput ("help":_) = do 251 | outputStrLn "Available subcommands:" 252 | outputStrLn "help - Display this help" 253 | outputStrLn "list - List available servers" 254 | outputStrLn "new
- Create a new server" 255 | outputStrLn "delete - Delete an existing server" 256 | serverInput ("list":_) = do 257 | servers <- liftIO DB.getServers 258 | forM_ servers $ \server -> do 259 | outputStrLn . T.unpack $ server ^. serverName 260 | serverInput ("new":name:address:_) = do 261 | liftIO $ DB.newServer (Server (T.pack name) (T.pack address)) 262 | outputStrLn "Server created" 263 | serverInput ("delete":name:_) = do 264 | liftIO $ DB.deleteServer (T.pack name) 265 | outputStrLn "Server deleted" 266 | serverInput _ = serverInput ["help"] 267 | 268 | connectInput :: [String] -> InputT IO () 269 | connectInput (profile:server:_) = do 270 | outputStrLn "Connecting to server" 271 | printfunc <- getExternalPrint 272 | liftIO $ do 273 | profilem <- DB.getProfile (T.pack profile) 274 | serverm <- DB.getServer (T.pack server) 275 | case profilem of 276 | Nothing -> pure () 277 | Just profile -> 278 | case serverm of 279 | Nothing -> pure () 280 | Just server -> do 281 | clientToken <- DB.getClientToken 282 | responsem <- Yggdrasil.refresh (Yggdrasil.RefreshRequest (profile ^. profileToken) 283 | clientToken 284 | False) 285 | case responsem of 286 | Nothing -> printfunc "Could not refresh token - try recreating the profile" 287 | Just response -> do 288 | DB.updateAccessToken (profile ^. profileUsername) (response ^. Yggdrasil.accessToken) 289 | let newprofile = profile & profileToken .~ (response ^. Yggdrasil.accessToken) 290 | inbound <- atomically $ newTChan 291 | outbound <- atomically $ newTChan 292 | shutdown <- newIORef False 293 | mc <- async (minecraftThread inbound outbound shutdown newprofile server printfunc) 294 | frp <- async (frpThread inbound outbound shutdown newprofile printfunc) 295 | link2 mc frp 296 | connectInput _ = outputStrLn "You need to provide a profile and a server" 297 | 298 | completeInput :: CompletionFunc IO 299 | completeInput (l, r) = case splitOn " " (reverse l) of 300 | (_:[]) -> completeWords ["quit", "profiles", "servers", "connect"] (l, r) 301 | ("profiles":_) -> completeProfiles (l, r) 302 | ("servers":_) -> completeServers (l, r) 303 | ("connect":profile:[]) -> completeProfile (l, r) 304 | ("connect":_:server:[]) -> completeServer (l, r) 305 | _ -> noCompletion (l, r) 306 | where 307 | completeWords :: [String] -> CompletionFunc IO 308 | completeWords ws = completeWord Nothing " " $ \w -> pure . map simpleCompletion . filter (w `isPrefixOf`) $ ws 309 | 310 | completeProfile :: CompletionFunc IO 311 | completeProfile (l, r) = (fmap (T.unpack . view profileUsername) <$> DB.getProfiles) >>= flip completeWords (l, r) 312 | 313 | completeServer :: CompletionFunc IO 314 | completeServer (l, r) = (fmap (T.unpack . view serverName) <$> DB.getServers) >>= flip completeWords (l, r) 315 | 316 | completeProfiles :: CompletionFunc IO 317 | completeProfiles (l, r) = case splitOn " " (reverse l) of 318 | (_:_:[]) -> completeWords ["help", "list", "new", "delete"] (l, r) 319 | (_:"delete":profile:[]) -> completeProfile (l, r) 320 | _ -> noCompletion (l, r) 321 | 322 | completeServers :: CompletionFunc IO 323 | completeServers (l, r) = case splitOn " " (reverse l) of 324 | (_:_:[]) -> completeWords ["help", "list", "new", "delete"] (l, r) 325 | (_:"delete":profile:[]) -> completeServer (l, r) 326 | _ -> noCompletion (l, r) 327 | 328 | main :: IO () 329 | main = do 330 | runInputT (defaultSettings :: Settings IO){historyFile=Just ".minecraftcli_history", complete=completeInput} $ do 331 | loop 332 | where loop :: InputT IO () 333 | loop = do 334 | minput <- getInputLine "% " 335 | case words <$> minput of 336 | Nothing -> pure () 337 | Just ("quit":_) -> pure () 338 | Just ("profiles":args) -> profileInput args >> loop 339 | Just ("servers":args) -> serverInput args >> loop 340 | Just ("connect":args) -> connectInput args >> loop 341 | Just input -> do 342 | outputStrLn ("Unrecognised command: " ++ unwords input) 343 | outputStrLn ("Available commands:") 344 | outputStrLn ("quit - Close MinecraftCLI") 345 | outputStrLn ("profiles - Manage profiles") 346 | outputStrLn ("servers - Manage servers") 347 | outputStrLn ("connect - Connect a profile to a server") 348 | loop 349 | 350 | mkPPAL :: (Double, Double, Double) -> SBPacket 351 | mkPPAL (x, y, z) = SBPlayerPositionAndLook $ SBPlayerPositionAndLookPayload (x ^. network) (y ^. network) (z ^. network) 0 0 True 352 | 353 | whileM :: Monad f => f Bool -> f () -> f () 354 | whileM c x = c >>= \case 355 | False -> pure () 356 | True -> x >> whileM c x 357 | 358 | uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d 359 | uncurry3 f (a, b, c) = f a b c 360 | -------------------------------------------------------------------------------- /cbits/crypt.c: -------------------------------------------------------------------------------- 1 | #include "crypt.h" 2 | 3 | #include 4 | #include 5 | #include 6 | 7 | MCRYPT *newCipher(char *key, char *iv) 8 | { 9 | MCRYPT td = mcrypt_module_open("rijndael-128", NULL, "cfb", NULL); 10 | int iv_size = mcrypt_enc_get_iv_size(td); 11 | char *IV = malloc(iv_size); 12 | memcpy(IV, iv, iv_size); 13 | mcrypt_generic_init(td, key, 16, iv); 14 | 15 | MCRYPT *td_ptr = malloc(sizeof(td)); 16 | memcpy(td_ptr, &td, sizeof(td)); 17 | return td_ptr; 18 | } 19 | 20 | void closeCipher(MCRYPT *td) 21 | { 22 | mcrypt_generic_deinit(*td); 23 | mcrypt_module_close(*td); 24 | free(td); 25 | } 26 | 27 | void decrypt(MCRYPT *td, char *cipher, int len) 28 | { 29 | mdecrypt_generic(*td, cipher, len); 30 | } 31 | 32 | void encrypt(MCRYPT *td, char *plain, int len) 33 | { 34 | mcrypt_generic(*td, plain, len); 35 | } 36 | -------------------------------------------------------------------------------- /cbits/crypt.h: -------------------------------------------------------------------------------- 1 | #ifndef __CRYPT_H__ 2 | #define __CRYPT_H__ 3 | 4 | #include 5 | 6 | MCRYPT *newCipher(char *key, char *iv); 7 | void closeCipher(MCRYPT *td); 8 | void encrypt(MCRYPT *td, char *plain, int len); 9 | void decrypt(MCRYPT *td, char *cipher, int len); 10 | 11 | #endif //__CRYPT_H__ 12 | -------------------------------------------------------------------------------- /src/Foreign/Crypt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} 2 | 3 | module Foreign.Crypt ( newCipher 4 | , closeCipher 5 | , decrypt 6 | , Cipher 7 | ) where 8 | 9 | import Data.ByteString (ByteString) 10 | import qualified Data.ByteString as BS 11 | 12 | import Foreign 13 | import Foreign.C.String 14 | import Foreign.C.Types 15 | 16 | data CCipher 17 | type Cipher = Ptr CCipher 18 | 19 | foreign import ccall "crypt.h newCipher" c_newCipher :: CString -> CString -> IO Cipher 20 | 21 | foreign import ccall "crypt.h closeCipher" c_closeCipher :: Cipher -> IO () 22 | 23 | foreign import ccall "crypt.h decrypt" c_decrypt :: Cipher -> CString -> CInt -> IO () 24 | 25 | 26 | newCipher :: ByteString -> ByteString -> IO Cipher 27 | newCipher key iv = BS.useAsCStringLen key $ \(ckey, _) -> 28 | BS.useAsCStringLen iv $ \(civ, _) -> 29 | c_newCipher ckey civ 30 | 31 | closeCipher :: Cipher -> IO () 32 | closeCipher = c_closeCipher 33 | 34 | decrypt :: Cipher -> ByteString -> IO ByteString 35 | decrypt c cipher = BS.useAsCStringLen cipher $ \(ccipher, len) -> do 36 | c_decrypt c ccipher (fromIntegral len) 37 | BS.packCStringLen (ccipher, len) 38 | -------------------------------------------------------------------------------- /src/Network/Protocol/Minecraft.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, RecordWildCards, TemplateHaskell, MultiParamTypeClasses #-} 2 | {-# LANGUAGE FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, RankNTypes #-} 3 | module Network.Protocol.Minecraft where 4 | 5 | import Control.Lens 6 | import Data.Binary (Binary) 7 | import Data.Maybe (fromMaybe) 8 | import qualified Data.Text as Text 9 | import Data.Text (Text) 10 | import Data.Word 11 | import Control.Monad.State 12 | import GHC.IO.Handle 13 | import qualified Network.Protocol.Minecraft.Encoding as Encoding 14 | import Network.Protocol.Minecraft.Encoding ( EncodedT, runEncodedT, defaultEncodingState, generateSharedKey 15 | , createServerHash, enableEncryption, setCompressionThreshold 16 | ) 17 | import Network.Protocol.Minecraft.Packet 18 | import Network.Protocol.Minecraft.Types 19 | import qualified Network.Protocol.Minecraft.Yggdrasil as Yggdrasil 20 | import Network.Socket as Socket 21 | import System.IO (IOMode(..), hReady) 22 | 23 | newtype MinecraftT m a = MinecraftT { unMinecraftT :: StateT MinecraftState (EncodedT m) a 24 | } deriving (Functor, Applicative, Monad, MonadIO) 25 | 26 | instance MonadTrans MinecraftT where 27 | lift = MinecraftT . lift . lift 28 | 29 | type Minecraft = MinecraftT IO 30 | 31 | data MinecraftState = MinecraftState { minecraftStateConnectionState :: ConnectionState 32 | , minecraftStateDimension :: Dimension 33 | , minecraftStateDifficulty :: Word8 34 | , minecraftStateGamemode :: Word8 35 | , minecraftStateMc_server :: HostName 36 | , minecraftStateMc_port :: PortNumber 37 | , minecraftStateHandle :: Handle 38 | } 39 | makeFields ''MinecraftState 40 | 41 | defaultMinecraftState :: MinecraftState 42 | defaultMinecraftState = MinecraftState { minecraftStateConnectionState = Handshaking 43 | , minecraftStateDimension = Overworld 44 | , minecraftStateDifficulty = 2 45 | , minecraftStateGamemode = 0 46 | , minecraftStateMc_server = "" 47 | , minecraftStateMc_port = 25565 48 | , minecraftStateHandle = undefined 49 | } 50 | 51 | runMinecraftT :: Monad m => Handle -> MinecraftState -> MinecraftT m a -> m a 52 | runMinecraftT handle state = fmap fst . runEncodedT (defaultEncodingState handle) . flip evalStateT state . unMinecraftT 53 | 54 | runMinecraft :: Handle -> MinecraftState -> Minecraft a -> IO a 55 | runMinecraft = runMinecraftT 56 | 57 | getState :: Monad m => MinecraftT m MinecraftState 58 | getState = MinecraftT get 59 | 60 | getStates :: Monad m => Lens' MinecraftState a -> MinecraftT m a 61 | getStates = MinecraftT . use 62 | 63 | getConnectionState :: Monad m => MinecraftT m ConnectionState 64 | getConnectionState = MinecraftT $ use connectionState 65 | 66 | receivePacket :: (Monad m, MonadIO m) => MinecraftT m (Maybe CBPacket) 67 | receivePacket = do 68 | connState <- getConnectionState 69 | liftMC $ Encoding.readPacket connState 70 | 71 | hasPacket :: (Monad m, MonadIO m) => MinecraftT m Bool 72 | hasPacket = getStates handle >>= liftIO . hReady 73 | 74 | sendPacket :: (HasPacketID a, Binary a, Monad m, MonadIO m) => a -> MinecraftT m () 75 | sendPacket p = liftMC $ Encoding.sendPacket p 76 | 77 | connect :: (Monad m, MonadIO m) => HostName -> Maybe PortNumber -> MinecraftT m a -> m (Either String a) 78 | connect host port' mc = do 79 | let port = fromMaybe 25565 port' 80 | addrs <- liftIO $ getAddrInfo Nothing (Just host) (Just $ show port) 81 | if null addrs 82 | then pure . Left $ "Unable to find host " ++ host 83 | else do 84 | sock <- liftIO $ socket AF_INET Stream defaultProtocol 85 | liftIO $ Socket.connect sock (addrAddress $ addrs !! 0) 86 | hdl <- liftIO $ socketToHandle sock ReadWriteMode 87 | Right <$> runMinecraftT hdl (defaultMinecraftState & mc_server .~ host & mc_port .~ port & handle .~ hdl) mc 88 | <* liftIO (hClose hdl) 89 | 90 | handshake :: (Monad m, MonadIO m) => MinecraftT m () 91 | handshake = do 92 | host <- getStates mc_server 93 | port <- getStates mc_port 94 | sendPacket $ SBHandshakePayload 340 (NetworkText $ Text.pack host) (fromIntegral port) LoggingIn 95 | setConnectionState LoggingIn 96 | 97 | login :: (Monad m, MonadIO m) => Text -> Text -> Text -> MinecraftT m (Either String CBLoginSuccessPayload) 98 | login username uuid token = do 99 | sendPacket $ SBLoginStartPayload (NetworkText username) 100 | p <- receivePacket 101 | case p of 102 | Just (CBLoginSuccess succ) -> setConnectionState Playing >> pure (Right succ) 103 | Just (CBEncryptionRequest encRequest) -> do 104 | sharedSecret <- liftIO $ generateSharedKey 105 | let serverHash = createServerHash (unNetworkText $ encRequest ^. serverID) sharedSecret ((lengthBS . view pubKey) encRequest) 106 | joinRequest = Yggdrasil.JoinRequest token uuid (Text.pack serverHash) 107 | joinSucc <- liftIO $ Yggdrasil.join joinRequest 108 | if not joinSucc 109 | then pure . Left $ "Unable to authenticate with mojang servers" 110 | else do 111 | Just response <- liftIO $ Encoding.encryptionResponse sharedSecret encRequest 112 | sendPacket response 113 | encSucc <- liftMC $ enableEncryption sharedSecret 114 | if not encSucc 115 | then pure . Left $ "Unable to enable encryption" 116 | else do 117 | loginSuccPacket <- whileM $ do 118 | Just packet <- receivePacket 119 | case packet of 120 | CBSetCompression (CBSetCompressionPayload thresh) -> 121 | liftMC $ setCompressionThreshold (fromIntegral thresh) >> pure Nothing 122 | CBLoginSuccess x -> setConnectionState Playing >> pure (Just (Right x)) 123 | _ -> pure . Just $ Left "Unexpected packet received during login" 124 | Just (CBJoinGame joinGame) <- receivePacket 125 | setGamemode $ joinGame ^. gamemode 126 | setDifficulty $ joinGame ^. difficulty 127 | setDimension $ joinGame ^. dimension 128 | pure loginSuccPacket 129 | where whileM :: Monad m => m (Maybe a) -> m a 130 | whileM action = do 131 | cont <- action 132 | case cont of 133 | Nothing -> whileM action 134 | Just x -> pure x 135 | 136 | setConnectionState :: Monad m => ConnectionState -> MinecraftT m () 137 | setConnectionState c = MinecraftT $ connectionState .= c 138 | 139 | setGamemode :: Monad m => Word8 -> MinecraftT m () 140 | setGamemode gm = MinecraftT $ gamemode .= gm 141 | 142 | setDifficulty :: Monad m => Word8 -> MinecraftT m () 143 | setDifficulty dif = MinecraftT $ difficulty .= dif 144 | 145 | setDimension :: Monad m => Dimension -> MinecraftT m () 146 | setDimension dim = MinecraftT $ dimension .= dim 147 | 148 | liftMC :: Monad m => EncodedT m a -> MinecraftT m a 149 | liftMC = MinecraftT . lift 150 | -------------------------------------------------------------------------------- /src/Network/Protocol/Minecraft/Encoding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving, StandaloneDeriving, DeriveGeneric #-} 2 | module Network.Protocol.Minecraft.Encoding ( generateSharedKey 3 | , encryptionResponse 4 | , setCompressionThreshold 5 | , enableEncryption 6 | , createServerHash 7 | , defaultEncodingState 8 | , runEncodedT 9 | , EncodedT 10 | , sendPacket 11 | , readPacket 12 | ) where 13 | 14 | import qualified Codec.Compression.Zlib as Zlib 15 | import Control.Lens ((^.)) 16 | import Control.Monad 17 | import Control.Monad.IO.Class 18 | import Control.Monad.State 19 | import Control.Monad.Trans.Maybe 20 | import Crypto.Cipher.AES (AES128) 21 | import Crypto.Cipher.Types 22 | import Crypto.Hash 23 | import Crypto.Error (CryptoFailable(..)) 24 | import Crypto.PubKey.RSA 25 | import qualified Crypto.PubKey.RSA.PKCS15 as RSA 26 | import Crypto.Random (getRandomBytes) 27 | import Data.ASN1.BinaryEncoding (DER(..)) 28 | import Data.ASN1.Encoding 29 | import Data.ASN1.Types(fromASN1) 30 | import Data.Binary (Binary) 31 | import qualified Data.Binary as Binary 32 | import qualified Data.Binary.Get as Binary 33 | import qualified Data.Binary.Put as Binary 34 | import Data.Bits 35 | import qualified Data.ByteString as BS 36 | import Data.ByteString (ByteString) 37 | import qualified Data.ByteString.Lazy as BSL 38 | import Data.Monoid ((<>)) 39 | import qualified Data.Text.Encoding as TE 40 | import Data.Text (Text) 41 | import Data.Word 42 | import Data.X509 43 | import qualified Foreign.Crypt as Crypt 44 | import GHC.IO.Handle 45 | import GHC.Generics 46 | import Network.Protocol.Minecraft.Packet 47 | import Network.Protocol.Minecraft.Types 48 | import Numeric 49 | 50 | data EncryptionState = EncryptionState { aes :: AES128 51 | , encryptSR :: ByteString 52 | , decryptSR :: Crypt.Cipher 53 | } 54 | 55 | data EncodingState = EncodingState { encryptionState :: Maybe EncryptionState 56 | , compressionThreshold :: Int 57 | , handle :: Handle 58 | } 59 | 60 | newtype EncodedT m a = EncodedT { unEncodedT :: StateT EncodingState m a } 61 | deriving (Functor, Applicative, Monad, MonadState EncodingState, MonadTrans, MonadIO) 62 | 63 | runEncodedT :: EncodingState -> EncodedT m a -> m (a, EncodingState) 64 | runEncodedT initialState = flip runStateT initialState . unEncodedT 65 | 66 | decodePubKey :: ByteString -> Maybe PublicKey 67 | decodePubKey keyBytes = do 68 | Right asn1 <- pure $ decodeASN1' DER keyBytes 69 | Right (PubKeyRSA key, _) <- pure $ fromASN1 asn1 70 | pure key 71 | 72 | generateSharedKey :: IO ByteString 73 | generateSharedKey = getRandomBytes 16 74 | 75 | getCipher :: ByteString -> Maybe AES128 76 | getCipher secret = do 77 | CryptoPassed cipher <- pure $ cipherInit secret 78 | pure cipher 79 | 80 | defaultEncodingState :: Handle -> EncodingState 81 | defaultEncodingState handle = EncodingState Nothing (-1) handle 82 | 83 | enableEncryption :: MonadIO m => ByteString -> EncodedT m Bool 84 | enableEncryption secret = do 85 | case getCipher secret of 86 | Nothing -> pure False 87 | Just cipher -> do 88 | decryptor <- liftIO $ Crypt.newCipher secret secret 89 | modify (\s -> s{encryptionState = Just $ EncryptionState cipher secret decryptor}) 90 | pure True 91 | 92 | setCompressionThreshold :: Monad m => Int -> EncodedT m () 93 | setCompressionThreshold threshold = modify (\s -> s{compressionThreshold = threshold}) 94 | 95 | decrypt :: MonadIO m => ByteString -> EncodedT m ByteString 96 | decrypt ciphertext = do 97 | encState' <- gets encryptionState 98 | case encState' of 99 | Nothing -> pure ciphertext 100 | Just encState -> do 101 | let sr = decryptSR encState 102 | ret <- liftIO $ Crypt.decrypt sr ciphertext 103 | pure ret 104 | 105 | encrypt :: Monad m => ByteString -> EncodedT m ByteString 106 | encrypt plaintext = do 107 | encState' <- gets encryptionState 108 | case encState' of 109 | Nothing -> pure plaintext 110 | Just encState -> do 111 | let sr = encryptSR encState 112 | cipher = aes encState 113 | (ret, newSR) = cfb8Encrypt cipher sr plaintext 114 | newEncState = encState{encryptSR = newSR} 115 | modify $ \s -> s{encryptionState = Just newEncState} 116 | pure ret 117 | 118 | data CompressedPacket = CompressedPacket VarInt ByteString 119 | deriving (Generic) 120 | 121 | instance Binary CompressedPacket where 122 | get = CompressedPacket <$> Binary.get <*> (BSL.toStrict <$> Binary.getRemainingLazyByteString) 123 | 124 | put (CompressedPacket compLen payload) = Binary.put compLen >> Binary.putByteString payload 125 | 126 | readPacket :: MonadIO m => ConnectionState -> EncodedT m (Maybe CBPacket) 127 | readPacket state = do 128 | closed <- connectionClosed 129 | if closed 130 | then pure Nothing 131 | else Just . Binary.runGet (getPacket state) . BSL.fromStrict <$> readPacketData 132 | 133 | readPacketData :: MonadIO m => EncodedT m ByteString 134 | readPacketData = do 135 | handle <- gets handle 136 | len <- readVarInt 137 | compThresh <- gets compressionThreshold 138 | packet <- liftIO (BS.hGet handle (fromIntegral len)) >>= decrypt 139 | let (decompressedLength, payload) = if compThresh >= 0 140 | then let (CompressedPacket decompressedLength payload) = Binary.decode (BSL.fromStrict packet) 141 | in (decompressedLength, payload) 142 | else (0, packet) 143 | if decompressedLength > 0 144 | then pure . BSL.toStrict . Zlib.decompress . BSL.fromStrict $ payload 145 | else pure payload 146 | 147 | connectionClosed :: MonadIO m => EncodedT m Bool 148 | connectionClosed = gets handle >>= liftIO . hIsEOF 149 | 150 | sendPacket :: (MonadIO m, Binary p, HasPacketID p) => p -> EncodedT m () 151 | sendPacket packet = do 152 | handle <- gets handle 153 | compThresh <- gets compressionThreshold 154 | let payload = Binary.runPut $ Binary.put packet 155 | packetID = Binary.runPut . Binary.put $ getPacketID packet 156 | compressedData = Zlib.compress $ packetID <> payload 157 | payloadLength = fromIntegral $ BSL.length payload 158 | dataLength = packetIDLength + payloadLength 159 | dataLength' = Binary.runPut $ Binary.put dataLength 160 | dataLength'length = fromIntegral $ BSL.length dataLength' 161 | compressedLength = fromIntegral $ BSL.length compressedData 162 | packetIDLength = fromIntegral $ BSL.length packetID 163 | packedPacket = Binary.runPut $ 164 | if compThresh < 0 165 | then do 166 | Binary.put (dataLength :: VarInt) 167 | Binary.putLazyByteString packetID 168 | Binary.putLazyByteString payload 169 | else if fromIntegral dataLength < compThresh 170 | then do 171 | Binary.put (dataLength + 1 :: VarInt) 172 | Binary.put (0 :: VarInt) 173 | Binary.putLazyByteString packetID 174 | Binary.putLazyByteString payload 175 | else do 176 | Binary.put (compressedLength + dataLength'length :: VarInt) 177 | Binary.put dataLength 178 | Binary.putLazyByteString compressedData 179 | encrypt (BSL.toStrict packedPacket) >>= liftIO . BS.hPut handle 180 | 181 | readVarInt :: MonadIO m => EncodedT m VarInt 182 | readVarInt = fmap (snd . unpackVarInt . BS.pack . reverse) $ go [] 183 | where go :: MonadIO m => [Word8] -> EncodedT m [Word8] 184 | go rest = do 185 | handle <- gets handle 186 | fstByteBS <- liftIO $ BS.hGet handle 1 187 | decryptedFstByteBS <- decrypt fstByteBS 188 | let fstByte = decryptedFstByteBS `BS.index` 0 189 | if fstByte `testBit` 7 190 | then go (fstByte : rest) 191 | else pure $ fstByte : rest 192 | 193 | encryptionResponse :: ByteString -> CBEncryptionRequestPayload -> IO (Maybe SBEncryptionResponsePayload) 194 | encryptionResponse secret encryptionRequest = runMaybeT $ do 195 | publicKey <- maybeZero $ decodePubKey (lengthBS $ encryptionRequest ^. pubKey) 196 | encryptedSecret <- eitherAToMaybeT $ RSA.encrypt publicKey secret 197 | encryptedToken <- eitherAToMaybeT $ RSA.encrypt publicKey (lengthBS $ encryptionRequest ^. verifyToken) 198 | pure $ SBEncryptionResponsePayload (LengthBS 128 encryptedSecret) (LengthBS 128 encryptedToken) 199 | 200 | maybeZero :: (MonadPlus m) => Maybe a -> m a 201 | maybeZero = maybe mzero pure 202 | 203 | eitherToMaybe :: Either a b -> Maybe b 204 | eitherToMaybe = either (const Nothing) Just 205 | 206 | eitherAToMaybeT :: Applicative m => m (Either a b) -> MaybeT m b 207 | eitherAToMaybeT = MaybeT . fmap eitherToMaybe 208 | 209 | -- Function taken from https://github.com/Lazersmoke/civskell/blob/ebf4d761362ee42935faeeac0fe447abe96db0b5/src/Civskell/Tech/Encrypt.hs#L154-L165 210 | -- Encrypt a bytestring using the cfb8 aes128 cipher, and the provided shift register 211 | cfb8Encrypt :: AES128 -> BS.ByteString -> BS.ByteString -> (BS.ByteString,BS.ByteString) 212 | cfb8Encrypt c i = BS.foldl magic (BS.empty,i) 213 | where 214 | -- Does a single step (one byte) of a CFB8 encryption 215 | -- add the cipher text to the output, and return the updated shift register 216 | magic (ds,iv) d = (ds `BS.snoc` ct,ivFinal) 217 | where 218 | -- use the MSB of the encrypted shift register to encrypt the current plaintext 219 | ct = BS.head (ecbEncrypt c iv) `xor` d 220 | -- shift the new ciphertext into the shift register 221 | ivFinal = BS.tail iv `BS.snoc` ct 222 | 223 | createServerHash :: Text -> ByteString -> ByteString -> String 224 | createServerHash serverId' secret pubKey = 225 | let serverId = TE.encodeUtf8 serverId' 226 | digest :: Digest SHA1 227 | digest = hashFinalize $ hashUpdates hashInit [serverId, secret, pubKey] 228 | protoHash :: Integer 229 | protoHash = fst . head . readHex . show $ digest -- FIXME 230 | isNegative = protoHash `testBit` 159 231 | in if isNegative 232 | then let hash = (2^(160 :: Int) - 1) `xor` (protoHash - 1) 233 | in "-" ++ showHex hash "" 234 | else showHex protoHash "" 235 | -------------------------------------------------------------------------------- /src/Network/Protocol/Minecraft/Packet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DeriveFunctor, RecordWildCards, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies #-} 2 | module Network.Protocol.Minecraft.Packet where 3 | 4 | import Data.Binary 5 | import Data.Binary.Get 6 | import Data.Binary.Put 7 | import Data.ByteString (ByteString) 8 | import qualified Data.ByteString.Lazy as BSL 9 | import Data.Int 10 | import GHC.Generics 11 | import Network.Protocol.Minecraft.Packet.TH 12 | import Network.Protocol.Minecraft.Types 13 | 14 | [packets| 15 | [Clientbound] 16 | EncryptionRequest LoggingIn 1 17 | serverID :: NetworkText 18 | pubKey :: LengthBS 19 | verifyToken :: LengthBS 20 | deriving (Generic, Show) 21 | instance (Binary) 22 | 23 | LoginSuccess LoggingIn 2 24 | uuid :: NetworkText 25 | username :: NetworkText 26 | deriving (Show, Generic) 27 | instance (Binary) 28 | 29 | SetCompression LoggingIn 3 30 | threshold :: VarInt 31 | deriving (Show, Generic) 32 | instance (Binary) 33 | 34 | ChatMessage Playing 0x0F 35 | chatMessage :: NetworkText 36 | position :: Word8 37 | deriving (Show, Generic) 38 | instance (Binary) 39 | 40 | ConfirmTransaction Playing 0x11 41 | windowId :: Int8 42 | actionNumber :: Int16 43 | accepted :: Bool 44 | deriving (Show, Generic) 45 | instance (Binary) 46 | 47 | CloseWindow Playing 0x12 48 | windowId :: Word8 49 | deriving (Show, Generic) 50 | instance (Binary) 51 | 52 | OpenWindow Playing 0x13 53 | windowId :: Word8 54 | windowType :: NetworkText 55 | windowTitle :: NetworkText 56 | numberOfSlots :: Word8 57 | deriving (Show, Generic) 58 | instance (Binary) 59 | 60 | WindowItems Playing 0x14 61 | windowId :: Int8 62 | count :: Int16 63 | deriving (Show, Generic) 64 | instance (Binary) 65 | 66 | SetSlot Playing 0x16 67 | windowId :: Int8 68 | slot :: Int16 69 | slotData :: Slot 70 | deriving (Show, Generic) 71 | instance (Binary) 72 | 73 | DisconnectPlay Playing 0x1A 74 | reason :: NetworkText 75 | deriving (Show, Generic) 76 | instance (Binary) 77 | 78 | JoinGame Playing 0x23 79 | playerEid :: Int32 80 | gamemode :: Word8 81 | dimension :: Dimension 82 | difficulty :: Word8 83 | maxPlayers :: Word8 84 | levelType :: NetworkText 85 | reducedDebugInfo :: Bool 86 | deriving (Show, Generic) 87 | instance (Binary) 88 | 89 | KeepAlive Playing 0x1F 90 | keepAliveId :: Int64 91 | deriving (Show, Generic) 92 | instance (Binary) 93 | 94 | PlayerPositionAndLook Playing 0x2F 95 | x :: NetworkDouble 96 | y :: NetworkDouble 97 | z :: NetworkDouble 98 | yaw :: NetworkFloat 99 | pitch :: NetworkFloat 100 | flags :: Word8 101 | posLookID :: VarInt 102 | deriving (Show, Generic) 103 | instance (Binary) 104 | 105 | Respawn Playing 0x35 106 | dimension :: Dimension 107 | difficulty :: Word8 108 | gamemode :: Word8 109 | levelType :: NetworkText 110 | deriving (Show, Generic) 111 | instance (Binary) 112 | 113 | 114 | 115 | [Serverbound] 116 | Handshake Handshaking 0x00 117 | protocolVersion :: VarInt 118 | address :: NetworkText 119 | port :: Word16 120 | nextState :: ConnectionState 121 | deriving (Show, Generic) 122 | instance (Binary) 123 | 124 | LoginStart LoggingIn 0x00 125 | username :: NetworkText 126 | deriving (Show, Generic) 127 | instance (Binary) 128 | 129 | EncryptionResponse LoggingIn 0x01 130 | sharedSecret :: LengthBS 131 | verifyToken :: LengthBS 132 | deriving (Show, Generic) 133 | instance (Binary) 134 | 135 | TeleportConfirm Playing 0x00 136 | teleConfirmID :: VarInt 137 | deriving (Show, Generic) 138 | instance (Binary) 139 | 140 | ChatMessage Playing 0x02 141 | chatMessage :: NetworkText 142 | deriving (Show, Generic) 143 | instance (Binary) 144 | 145 | ClientStatus Playing 0x03 146 | actionID :: VarInt 147 | deriving (Show, Generic) 148 | instance (Binary) 149 | 150 | ClientSettings Playing 0x04 151 | locale :: NetworkText 152 | viewDistance :: Int8 153 | chatMode :: VarInt 154 | colors :: Bool 155 | displayedSkinParts :: Word8 156 | mainHand :: VarInt 157 | deriving (Show, Generic) 158 | instance (Binary) 159 | 160 | ClickWindow Playing 0x07 161 | windowId :: Word8 162 | slot :: Int16 163 | button :: Int8 164 | actionNumber :: Int16 165 | mode :: VarInt 166 | clickedItem :: Slot 167 | deriving (Show, Generic) 168 | instance (Binary) 169 | 170 | CloseWindow Playing 0x08 171 | windowId :: Word8 172 | deriving (Show, Generic) 173 | instance (Binary) 174 | 175 | KeepAlive Playing 0x0B 176 | keepAliveId :: Int64 177 | deriving (Show, Generic) 178 | instance (Binary) 179 | 180 | PlayerPositionAndLook Playing 0x0E 181 | x :: NetworkDouble 182 | y :: NetworkDouble 183 | z :: NetworkDouble 184 | yaw :: NetworkFloat 185 | pitch :: NetworkFloat 186 | onGround :: Bool 187 | deriving (Show, Generic) 188 | instance (Binary) 189 | 190 | PlayerBlockPlacement Playing 0x1F 191 | location :: Position 192 | face :: VarInt 193 | hand :: VarInt 194 | cursorX :: NetworkFloat 195 | cursorY :: NetworkFloat 196 | cursorZ :: NetworkFloat 197 | deriving (Show, Generic) 198 | instance (Binary) 199 | |] 200 | 201 | instance Binary CBUnknownPayload where 202 | get = CBUnknownPayload . BSL.toStrict <$> getRemainingLazyByteString 203 | put (CBUnknownPayload a) = putByteString a 204 | 205 | instance Binary SBUnknownPayload where 206 | get = SBUnknownPayload . BSL.toStrict <$> getRemainingLazyByteString 207 | put (SBUnknownPayload a) = putByteString a 208 | -------------------------------------------------------------------------------- /src/Network/Protocol/Minecraft/Packet/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, RecordWildCards #-} 2 | module Network.Protocol.Minecraft.Packet.TH ( packets 3 | ) where 4 | 5 | import Control.Lens.TH 6 | import Control.Monad (join) 7 | import Data.Binary (Binary, put, get, Get) 8 | import Data.Char (toLower, toUpper) 9 | import GHC.Generics (Generic) 10 | import Language.Haskell.TH 11 | import Language.Haskell.TH.Syntax 12 | import Language.Haskell.TH.Quote 13 | import Text.Parsec 14 | 15 | import Network.Protocol.Minecraft.Types 16 | 17 | type Parser = Parsec String () 18 | 19 | data Declaration = Declaration { declarationName :: String 20 | , connectionState :: ConnectionState 21 | , packetID :: Integer 22 | , fields :: [Field] 23 | , declarationDerives :: [String] 24 | , declarationInstances :: [String] 25 | } deriving (Show) 26 | 27 | data Field = Field { fieldName :: String 28 | , fieldType :: String 29 | } deriving (Show) 30 | 31 | parseDeclarations :: Monad m => (String, Int, Int) -> String -> m ([Declaration], [Declaration]) 32 | parseDeclarations (file, line, col) s = 33 | case parse p "" s of 34 | Left err -> fail $ show err 35 | Right decls -> pure decls 36 | where 37 | p :: Parser ([Declaration], [Declaration]) 38 | p = do 39 | pos <- getPosition 40 | setPosition $ (flip setSourceName) file $ (flip setSourceLine) line $ (flip setSourceColumn) col $ pos 41 | spaces 42 | _ <- string "[Clientbound]" 43 | spaces 44 | cb <- many $ (parseDeclaration <* many newline) 45 | spaces 46 | _ <- string "[Serverbound]" 47 | spaces 48 | sb <- many $ (parseDeclaration <* many newline) 49 | pure (cb, sb) 50 | 51 | parseDeclaration :: Parser Declaration 52 | parseDeclaration = Declaration <$> many alphaNum 53 | <*> (spaces *> parseConnectionState) 54 | <*> (spaces *> integer) 55 | <*> many (try (newline *> parseField)) 56 | <*> (try $ newline *> parseKWList "deriving") 57 | <*> (newline *> parseKWList "instance") 58 | 59 | integer :: Parser Integer 60 | integer = read <$> (hexadecimal <|> decimal) 61 | where decimal = many digit 62 | hexadecimal = do 63 | _ <- try $ string "0x" 64 | digits <- many1 hexDigit 65 | pure $ "0x" ++ digits 66 | 67 | parseConnectionState :: Parser ConnectionState 68 | parseConnectionState = const Playing <$> string "Playing" 69 | <|> const LoggingIn <$> string "LoggingIn" 70 | <|> const Handshaking <$> string "Handshaking" 71 | <|> const GettingStatus <$> string "GettingStatus" 72 | 73 | parseField :: Parser Field 74 | parseField = Field <$> (space *> spaces *> many alphaNum) 75 | <*> (spaces *> string "::" *> spaces *> many alphaNum) 76 | 77 | parseKWList :: String -> Parser [String] 78 | parseKWList kw = space *> spaces *> string kw *> spaces *> char '(' *> 79 | ((spaces *> many1 alphaNum <* spaces) `sepBy` char ',') <* 80 | char ')' 81 | 82 | packets :: QuasiQuoter 83 | packets = QuasiQuoter { quoteDec = declarationsQuoter 84 | , quoteExp = undefined 85 | , quotePat = undefined 86 | , quoteType = undefined 87 | } 88 | 89 | defaultBang :: Bang 90 | defaultBang = Bang NoSourceUnpackedness NoSourceStrictness 91 | 92 | mkBangType :: Type -> BangType 93 | mkBangType t = (defaultBang, t) 94 | 95 | mkVarBangType :: Name -> Type -> VarBangType 96 | mkVarBangType n t = (n, defaultBang, t) 97 | 98 | mkType :: [String] -> Q Type 99 | mkType [] = fail "This should never happen" 100 | mkType (x:xs) = do 101 | Just typ <- lookupTypeName x 102 | if null xs 103 | then pure $ ConT typ 104 | else AppT (ConT typ) <$> mkType xs 105 | 106 | declarationsQuoter :: String -> DecsQ 107 | declarationsQuoter s = do 108 | loc <- location 109 | (cb, sb) <- parseDeclarations (loc_filename loc, fst $ loc_start loc, snd $ loc_start loc) s 110 | (cbdecs, cbpayloads) <- mkDecs "CB" cb 111 | (sbdecs, sbpayloads) <- mkDecs "SB" sb 112 | lensifiedPayloads <- declareFields (pure $ cbpayloads ++ sbpayloads) 113 | pure $ getPacketSig : mkGetPacket cb : cbdecs ++ sbdecs ++ lensifiedPayloads 114 | 115 | 116 | mkDecs :: String -> [Declaration] -> Q ([Dec], [Dec]) 117 | mkDecs prefix decls = do 118 | (cons, payloads) <- unzip <$> (sequence $ mkConsPayload True prefix <$> decls) 119 | (unknownC, unknownPL) <- mkConsPayload False prefix $ Declaration { declarationName = "Unknown" 120 | , fields = [Field "unknownPayload" "ByteString"] 121 | , declarationDerives = ["Show"] 122 | , declarationInstances = [] 123 | , connectionState = undefined 124 | , packetID = undefined 125 | } 126 | 127 | let packetName = mkName $ prefix ++ "Packet" 128 | packet = DataD [] packetName [] Nothing (unknownC : cons) [DerivClause Nothing [ConT ''Show, ConT ''Generic]] 129 | packetHasPacketID <- generateHasPacketID packetName cons 130 | packetBinaryInstance <- packetBinary packetName cons 131 | pure $ (packet : packetHasPacketID : [packetBinaryInstance], unknownPL ++ join payloads) 132 | 133 | packetBinary :: Name -> [Con] -> Q Dec 134 | packetBinary packet cons = do 135 | let cons' = conName <$> cons 136 | putDef' <- putDef cons' 137 | pure $ InstanceD Nothing [] (AppT (ConT ''Binary) (ConT packet)) [putDef'] 138 | where putDef :: [Name] -> Q Dec 139 | putDef cons = do 140 | pats <- sequenceQ $ do 141 | con <- cons 142 | pure $ do 143 | varp <- newName "a" 144 | pure $ Clause [ConP con [VarP varp]] (NormalB (AppE (VarE 'put) (VarE varp))) [] 145 | pure $ FunD 'put pats 146 | conName :: Con -> Name 147 | conName (NormalC name _) = name 148 | conName _ = error "This should never happen" 149 | 150 | generateHasPacketID :: Name -> [Con] -> Q Dec 151 | generateHasPacketID packetName cons = do 152 | let passthrough name = do 153 | (NormalC con _ ) <- cons 154 | pure $ do 155 | pat <- newName "x" 156 | pure $ Clause [ConP con [VarP pat]] (NormalB $ AppE (VarE name) (VarE pat)) [] 157 | packetIDDecs <- sequence $ passthrough 'getPacketID 158 | modeDecs <- sequence $ passthrough 'mode 159 | let header = InstanceD Nothing [] (AppT (ConT ''HasPacketID) (ConT packetName)) 160 | ([ FunD 'getPacketID packetIDDecs 161 | , FunD 'mode modeDecs 162 | ]) 163 | pure header 164 | 165 | mkConsPayload :: Bool -> String -> Declaration -> Q (Con, [Dec]) 166 | mkConsPayload hasPacketID prefix Declaration{..} = do 167 | let payloadType = mkName $ prefix ++ declarationName ++ "Payload" 168 | fieldPrefix = [toLower (head prefix)] ++ drop 1 prefix ++ declarationName ++ "Payload" 169 | payloadCon Field{..} = mkVarBangType (mkName $ fieldPrefix ++ [toUpper (head fieldName)] ++ drop 1 fieldName) <$> mkType (words fieldType) 170 | payloadCons <- RecC payloadType <$> sequence (payloadCon <$> fields) 171 | derives <- DerivClause Nothing <$> sequence (mkType . words <$> declarationDerives) 172 | let payload = DataD [] payloadType [] Nothing [payloadCons] [derives] 173 | 174 | instances <- sequence $ mkType . words <$> declarationInstances 175 | let instanceDecls = flip (InstanceD Nothing []) [] <$> (flip AppT (ConT payloadType) <$> (instances)) 176 | 177 | packetIDInstance <- 178 | if hasPacketID 179 | then do 180 | mode <- lift connectionState 181 | let packetIDFun = FunD (mkName "getPacketID") [Clause [VarP (mkName "_")] (NormalB $ LitE $ IntegerL $ fromIntegral packetID) []] 182 | modeFun = FunD (mkName "mode") [Clause [VarP (mkName "_")] (NormalB mode) []] 183 | pure $ [InstanceD Nothing [] (AppT (ConT ''HasPacketID) (ConT payloadType)) [packetIDFun, modeFun]] 184 | else pure [] 185 | 186 | let con = NormalC (mkName $ prefix ++ declarationName) . (:[]) . mkBangType $ ConT payloadType 187 | pure $ (con, payload : packetIDInstance ++ instanceDecls) 188 | 189 | getPacketSig :: Dec 190 | getPacketSig = SigD (mkName "getPacket") (AppT (AppT ArrowT (ConT ''ConnectionState)) (AppT (ConT ''Get) (ConT (mkName "CBPacket")))) 191 | 192 | mkGetPacket :: [Declaration] -> Dec 193 | mkGetPacket decls = FunD (mkName "getPacket") $ clauses 194 | where hanshakingDecls = filter ((==Handshaking) . connectionState) decls 195 | loggingInDecls = filter ((==LoggingIn) . connectionState) decls 196 | playingDecls = filter ((==Playing) . connectionState) decls 197 | clauses = --mkGetPacketClause 'Handshaking hanshakingDecls 198 | mkGetPacketClause 'LoggingIn loggingInDecls 199 | : mkGetPacketClause 'Playing playingDecls 200 | : [Clause [WildP] defaultBody []] 201 | 202 | mkGetPacketClause :: Name -> [Declaration] -> Clause 203 | mkGetPacketClause state decls = Clause [ConP state []] 204 | (NormalB (DoE [ BindS (VarP (mkName "pid")) (SigE (VarE 'get) (AppT (ConT ''Get) (ConT ''VarInt))) 205 | , NoBindS (CaseE (VarE (mkName "pid")) $ (mkGetPacketMatch <$> decls) ++ [Match WildP defaultBody []]) 206 | ])) 207 | [] 208 | mkGetPacketMatch :: Declaration -> Match 209 | mkGetPacketMatch Declaration{..} = Match (LitP (IntegerL packetID)) (NormalB (AppE (AppE (VarE 'fmap) (ConE (mkName $ "CB" ++ declarationName))) (VarE 'get))) [] 210 | 211 | defaultBody :: Body 212 | defaultBody = NormalB (AppE (AppE (VarE 'fmap) (ConE (mkName "CBUnknown"))) (VarE 'get)) 213 | -------------------------------------------------------------------------------- /src/Network/Protocol/Minecraft/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, DefaultSignatures, FlexibleContexts, TypeSynonymInstances, GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE BinaryLiterals, FlexibleInstances, OverloadedStrings, DeriveLift, LambdaCase, RecordWildCards #-} 3 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, TemplateHaskell, DeriveGeneric, StandaloneDeriving #-} 4 | {-# LANGUAGE UndecidableInstances, ViewPatterns #-} 5 | module Network.Protocol.Minecraft.Types where 6 | 7 | import Control.Applicative (empty, (<|>)) 8 | import Control.Lens (makeFields, (^.)) 9 | import Control.Lens.Iso (Iso', iso) 10 | import Control.Monad.Identity 11 | import Data.Aeson 12 | import Data.Bits 13 | import Data.Binary (Binary(..)) 14 | import Data.Binary.Get 15 | import Data.Binary.Put 16 | import qualified Data.ByteString as BS 17 | import Data.ByteString (ByteString) 18 | import qualified Data.HashMap.Lazy as HML 19 | import Data.Int 20 | import Data.Maybe (fromMaybe) 21 | import Data.Monoid 22 | import Data.String (IsString) 23 | import Data.Text (Text) 24 | import qualified Data.Text.Encoding as TE 25 | import qualified Data.Vector as V 26 | import Data.Word 27 | import GHC.Generics 28 | import Language.Haskell.TH.Syntax (Lift) 29 | 30 | data Dimension = Overworld 31 | | Nether 32 | | TheEnd 33 | deriving (Show, Eq, Ord) 34 | 35 | instance Enum Dimension where 36 | fromEnum Overworld = 0 37 | fromEnum Nether = -1 38 | fromEnum TheEnd = 1 39 | 40 | toEnum (-1) = Nether 41 | toEnum 0 = Overworld 42 | toEnum 1 = TheEnd 43 | toEnum x = error $ "Unknown dimension " ++ show x 44 | 45 | instance Binary Dimension where 46 | put = (put :: Int32 -> Put) . fromIntegral . fromEnum 47 | get = (toEnum . fromIntegral) <$> (get :: Get Int32) 48 | 49 | data LengthBS = LengthBS { lengthBSLen :: VarInt 50 | , lengthBS :: ByteString 51 | } deriving (Show) 52 | 53 | instance Binary LengthBS where 54 | put LengthBS{..} = put lengthBSLen >> putByteString lengthBS 55 | get = do 56 | len <- get 57 | LengthBS len <$> getByteString (fromIntegral len) 58 | 59 | newtype VarInt = VarInt {unVarInt :: Int32} 60 | deriving (Show, Bits, Eq, Ord, Num, Integral, Real, Enum) 61 | 62 | newtype VarLong = VarLong {unVarLong :: Int64} 63 | deriving (Show, Bits, Eq, Ord, Num, Integral, Real, Enum) 64 | 65 | instance Binary VarInt where 66 | put = putByteString . packVarInt 67 | 68 | get = do 69 | initial <- getWhile (`testBit` 7) 70 | last <- getByteString 1 71 | pure . snd . unpackVarInt $ initial <> last 72 | 73 | instance Binary VarLong where 74 | put = putByteString . packVarLong 75 | 76 | get = do 77 | initial <- getWhile (`testBit` 7) 78 | last <- getByteString 1 79 | pure . snd . unpackVarLong $ initial <> last 80 | 81 | packVarVal :: (Show a, Bits a, Integral a) => Int -> a -> [Word8] 82 | packVarVal _ 0 = [0] 83 | packVarVal maxSegs' i' = go i' maxSegs' 84 | where go :: (Show a, Bits a, Integral a) => a -> Int -> [Word8] 85 | go _ 0 = [] 86 | go 0 _ = [] 87 | go i maxSegs = if newVal == 0 88 | then [temp] 89 | else temp `setBit` 7 : go newVal (maxSegs - 1) 90 | where temp = fromIntegral i .&. 0b01111111 :: Word8 91 | newVal = i `shiftR` 7 92 | 93 | packVarInt :: VarInt -> ByteString 94 | packVarInt vi = BS.pack $ packVarVal 5 (fromIntegral vi :: Word32) 95 | 96 | packVarLong :: VarLong -> ByteString 97 | packVarLong vl = BS.pack $ packVarVal 10 (fromIntegral vl :: Word64) 98 | 99 | unpackVarInt :: ByteString -> (ByteString, VarInt) 100 | unpackVarInt = fmap VarInt . unpackVarVal 101 | 102 | unpackVarLong :: ByteString -> (ByteString, VarLong) 103 | unpackVarLong = fmap VarLong . unpackVarVal 104 | 105 | unpackVarVal :: (Integral a, Bits a, Num a) => ByteString -> (ByteString, a) 106 | unpackVarVal bs = go $ BS.unpack bs 107 | where go :: (Num a, Bits a) => [Word8] -> (ByteString, a) 108 | go [] = ("", 0) 109 | go (x:xs) = if x `testBit` 7 110 | then let (rest, bit) = go xs 111 | in (rest, bit `shiftL` 7 .|. (fromIntegral x .&. 0b01111111)) 112 | else (BS.pack xs, fromIntegral x .&. 0b01111111) 113 | 114 | class NetworkVar src dst | src -> dst, dst -> src where 115 | network :: Iso' src dst 116 | 117 | newtype NetworkText = NetworkText {unNetworkText :: Text} 118 | deriving (Show, Eq, Ord, IsString, Monoid) 119 | 120 | instance Binary NetworkText where 121 | get = do 122 | len <- fromIntegral <$> (get :: Get VarInt) 123 | NetworkText . TE.decodeUtf8 <$> getByteString len 124 | 125 | put (NetworkText text) = do 126 | let bs = TE.encodeUtf8 text 127 | put (fromIntegral $ (BS.length bs) :: VarInt) 128 | putByteString bs 129 | 130 | instance NetworkVar Text NetworkText where 131 | network = iso NetworkText unNetworkText 132 | 133 | newtype NetworkFloat = NetworkFloat {unNetworkFloat :: Float} 134 | deriving (Show, Eq, Ord, Num, Floating, Fractional, Enum, Real, RealFloat, RealFrac) 135 | 136 | instance Binary NetworkFloat where 137 | get = NetworkFloat <$> getFloatbe 138 | put = putFloatbe . unNetworkFloat 139 | 140 | instance NetworkVar Float NetworkFloat where 141 | network = iso NetworkFloat unNetworkFloat 142 | 143 | newtype NetworkDouble = NetworkDouble {unNetworkDouble :: Double} 144 | deriving (Show, Eq, Ord, Num, Floating, Fractional, Enum, Real, RealFloat, RealFrac) 145 | 146 | instance Binary NetworkDouble where 147 | get = NetworkDouble <$> getDoublebe 148 | put = putDoublebe . unNetworkDouble 149 | 150 | instance NetworkVar Double NetworkDouble where 151 | network = iso NetworkDouble unNetworkDouble 152 | 153 | getWhile :: (Word8 -> Bool) -> Get ByteString 154 | getWhile p = fmap (fromMaybe "") . lookAheadM $ do 155 | byte <- getWord8 156 | if p byte 157 | then (Just . (BS.pack [byte] <>)) <$> getWhile p 158 | else pure Nothing 159 | 160 | data ConnectionState = Handshaking 161 | | LoggingIn 162 | | Playing 163 | | GettingStatus 164 | deriving (Show, Lift, Eq) 165 | 166 | class HasPacketID f where 167 | getPacketID :: f -> VarInt 168 | mode :: f -> ConnectionState 169 | 170 | class HasPayload f a | f -> a where 171 | getPayload :: f -> a 172 | 173 | instance Binary ConnectionState where 174 | put Handshaking = put (0 :: VarInt) 175 | put GettingStatus = put (1 :: VarInt) 176 | put LoggingIn = put (2 :: VarInt) 177 | put Playing = put (3 :: VarInt) 178 | 179 | get = getWord8 >>= pure . \case 180 | 0 -> Handshaking 181 | 1 -> GettingStatus 182 | 2 -> LoggingIn 183 | 3 -> Playing 184 | _ -> error "Unknown state" 185 | 186 | data ClickEvent = ClickEvent deriving (Generic, Show) 187 | data HoverEvent = HoverEvent deriving (Generic, Show) 188 | 189 | instance FromJSON ClickEvent 190 | instance FromJSON HoverEvent 191 | 192 | 193 | data Test f = Test (f Bool) 194 | 195 | data ChatShared f = ChatShared { chatSharedBold :: f Bool 196 | , chatSharedItalic :: f Bool 197 | , chatSharedUnderlined :: f Bool 198 | , chatSharedStrikethrough :: f Bool 199 | , chatSharedObfuscated :: f Bool 200 | , chatSharedColor :: f Text 201 | , chatSharedInsertion :: Maybe Text 202 | , chatSharedClickEvent :: ClickEvent 203 | , chatSharedHoverEvent :: HoverEvent 204 | } deriving (Generic) 205 | 206 | defaultChatShared :: ChatShared Maybe 207 | defaultChatShared = ChatShared Nothing Nothing Nothing Nothing Nothing Nothing Nothing ClickEvent HoverEvent 208 | 209 | baseChatShared :: ChatShared Identity 210 | baseChatShared = ChatShared false false false false false (Identity "white") Nothing ClickEvent HoverEvent 211 | where false = Identity False 212 | 213 | deriving instance (Show (f Bool), Show (f Text)) => Show (ChatShared f) 214 | 215 | instance FromJSON (ChatShared Maybe) where 216 | parseJSON (Object o) = ChatShared <$> o .:? "bold" 217 | <*> o .:? "italic" 218 | <*> o .:? "underlined" 219 | <*> o .:? "strikethrough" 220 | <*> o .:? "obfuscated" 221 | <*> o .:? "color" 222 | <*> o .:? "insertion" 223 | <*> pure ClickEvent 224 | <*> pure HoverEvent 225 | parseJSON _ = empty 226 | 227 | data ChatComponent f = StringComponent { chatComponentShared :: ChatShared f 228 | , chatComponentText :: Text 229 | , chatComponentExtra :: [ChatComponent f] 230 | } 231 | | TranslationComponent { chatComponentShared :: ChatShared f 232 | , chatComponentTranslate :: Text 233 | , chatComponentWith :: [ChatComponent f] 234 | , chatComponentExtra :: [ChatComponent f] 235 | } 236 | makeFields ''ChatShared 237 | makeFields ''ChatComponent 238 | 239 | deriving instance (Show (f Bool), Show (f Text)) => Show (ChatComponent f) 240 | 241 | instance FromJSON (ChatComponent Maybe) where 242 | parseJSON (Object o) | "text" `HML.member` o = StringComponent <$> parseJSON (Object o) 243 | <*> o .: "text" 244 | <*> (o .: "extra" <|> pure []) 245 | | "translate" `HML.member` o = TranslationComponent <$> parseJSON (Object o) 246 | <*> o .: "translate" 247 | <*> o .: "with" 248 | <*> (o .: "extra" <|> pure []) 249 | | otherwise = empty 250 | parseJSON (String s) = pure $ StringComponent defaultChatShared s [] 251 | parseJSON (Array a) | not (V.null a) = do 252 | first <- parseJSON (V.head a) 253 | rest <- sequence . V.toList $ parseJSON <$> V.drop 1 a 254 | pure $ StringComponent defaultChatShared first rest 255 | parseJSON _ = empty 256 | 257 | inheritStyle :: ChatShared Identity -> ChatShared Maybe -> ChatShared Identity 258 | inheritStyle base cc = ChatShared (Identity $ fromMaybe (runIdentity $ base ^. bold) (cc ^. bold)) 259 | (Identity $ fromMaybe (runIdentity $ base ^. italic) (cc ^. italic)) 260 | (Identity $ fromMaybe (runIdentity $ base ^. underlined) (cc ^. underlined)) 261 | (Identity $ fromMaybe (runIdentity $ base ^. strikethrough) (cc ^. strikethrough)) 262 | (Identity $ fromMaybe (runIdentity $ base ^. obfuscated) (cc ^. obfuscated)) 263 | (Identity $ fromMaybe (runIdentity $ base ^. color) (cc ^. color)) 264 | (cc ^. insertion) 265 | ClickEvent 266 | HoverEvent 267 | 268 | inheritChatComponent :: ChatShared Identity -> ChatComponent Maybe -> ChatComponent Identity 269 | inheritChatComponent base cc = case cc of 270 | StringComponent{} -> StringComponent canonicalStyle (cc ^. text) extras 271 | TranslationComponent{} -> let withs = inheritChatComponent canonicalStyle <$> cc ^. with 272 | in TranslationComponent canonicalStyle (cc ^. translate) withs extras 273 | where canonicalStyle = inheritStyle base (cc ^. shared) 274 | extras = inheritChatComponent canonicalStyle <$> cc ^. extra 275 | 276 | canonicalizeChatComponent :: ChatComponent Maybe -> ChatComponent Identity 277 | canonicalizeChatComponent = inheritChatComponent baseChatShared 278 | 279 | chatToText :: ChatComponent Identity -> Text 280 | chatToText (TranslationComponent _ key withs extra) = case key of 281 | "chat.type.text" -> "<" <> chatToText (withs !! 0) <> "> " 282 | <> chatToText (withs !! 1) <> extras 283 | "commands.message.display.incoming" -> chatToText (withs !! 0) <> " whispers to you: " 284 | <> chatToText (withs !! 1) <> extras 285 | _ -> key <> extras 286 | where extras = mconcat (chatToText <$> extra) 287 | chatToText (StringComponent _ t extra) = t <> mconcat (chatToText <$> extra) 288 | 289 | data Slot = Slot { slotBlockId :: Int16 290 | , slotItemCount :: Maybe Int8 291 | , slotItemDamage :: Maybe Int8 292 | -- NBT 293 | } deriving (Show) 294 | makeFields ''Slot 295 | 296 | instance Binary Slot where 297 | get = do 298 | blockId <- getInt16be 299 | if blockId == -1 300 | then pure $ Slot (-1) Nothing Nothing 301 | else Slot blockId <$> (Just <$> getInt8) <*> (Just <$> getInt8) 302 | put (Slot id count dmg) = do 303 | putInt16be id 304 | case count of 305 | Just c -> putInt8 c 306 | Nothing -> pure () 307 | case dmg of 308 | Just d -> putInt8 d 309 | Nothing -> pure () 310 | 311 | emptySlot :: Slot 312 | emptySlot = Slot (-1) Nothing Nothing 313 | 314 | isEmptySlot :: Slot -> Bool 315 | isEmptySlot (Slot (-1) _ _) = True 316 | isEmptySlot _ = False 317 | 318 | data Position = Position Int Int Int 319 | deriving (Show) 320 | 321 | instance Binary Position where 322 | get = do 323 | bytes <- getWord64be 324 | let xval = bytes `shiftR` 38 325 | yval = (bytes `shiftR` 26) .&. 0xFFF 326 | zval = (bytes `shiftL` 38) `shiftR` 38 327 | x = if xval > 2^25 328 | then xval - 2^26 329 | else xval 330 | y = if yval > 2^11 331 | then yval - 2^12 332 | else yval 333 | z = if zval > 2^25 334 | then zval - 2^26 335 | else zval 336 | pure $ Position (fromIntegral x) (fromIntegral y) (fromIntegral z) 337 | put (Position (fromIntegral -> x) (fromIntegral -> y) (fromIntegral -> z)) = do 338 | put ((((x .&. 0x3FFFFFF) `shiftL` 38) .|. ((y .&. 0xFFF) `shiftL` 26) .|. (z .&. 0x3FFFFFF)) :: Int64) 339 | 340 | -- TODO: 341 | -- Entity Metadata 342 | -- NBT Tag 343 | -- Angle (Word8) 344 | -- UUID 345 | -- 346 | -------------------------------------------------------------------------------- /src/Network/Protocol/Minecraft/Yggdrasil.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DataKinds, TypeOperators, OverloadedStrings, TemplateHaskell #-} 2 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-} 3 | module Network.Protocol.Minecraft.Yggdrasil ( join 4 | , JoinRequest(..) 5 | , authenticate 6 | , AuthenticationRequest(..) 7 | , AuthenticationResponse(..) 8 | , Agent(..) 9 | , defaultAgent 10 | , Profile(..) 11 | , refresh 12 | , RefreshRequest(..) 13 | , RefreshResponse(..) 14 | 15 | 16 | , agent 17 | , name 18 | , version 19 | , username 20 | , password 21 | , clientToken 22 | , requestUser 23 | , Network.Protocol.Minecraft.Yggdrasil.id 24 | , legacy 25 | , accessToken 26 | , availableProfiles 27 | , selectedProfile 28 | , serverId 29 | ) where 30 | 31 | import Control.Lens 32 | import Data.Aeson 33 | import Data.Char (toLower) 34 | import Data.Either (isRight) 35 | import Data.Text (Text) 36 | import Data.Proxy 37 | import GHC.Generics 38 | import Network.HTTP.Client (newManager) 39 | import Network.HTTP.Client.TLS (tlsManagerSettings) 40 | import Servant.API 41 | import Servant.Client 42 | 43 | labelModifier :: Int -> String -> String 44 | labelModifier c = mkLower . drop c 45 | where mkLower :: String -> String 46 | mkLower (x:xs) = (toLower x) : xs 47 | mkLower [] = [] 48 | 49 | data Agent = Agent { agentName :: Text 50 | , agentVersion :: Int 51 | } deriving (Generic, Show) 52 | 53 | instance ToJSON Agent where 54 | toJSON = genericToJSON defaultOptions{fieldLabelModifier=labelModifier 5} 55 | 56 | defaultAgent :: Agent 57 | defaultAgent = Agent "Minecraft" 1 58 | 59 | data AuthenticationRequest = AuthenticationRequest { authenticationRequestAgent :: Agent 60 | , authenticationRequestUsername :: Text 61 | , authenticationRequestPassword :: Text 62 | , authenticationRequestClientToken :: Text 63 | , authenticationRequestRequestUser :: Bool 64 | } deriving (Generic, Show) 65 | 66 | instance ToJSON AuthenticationRequest where 67 | toJSON = genericToJSON defaultOptions{fieldLabelModifier=labelModifier 21} 68 | 69 | data Profile = Profile { profileId :: Text 70 | , profileName :: Text 71 | , profileLegacy :: Maybe Bool 72 | } deriving (Generic, Show) 73 | 74 | instance FromJSON Profile where 75 | parseJSON = genericParseJSON defaultOptions{fieldLabelModifier=labelModifier 7} 76 | 77 | instance ToJSON Profile where 78 | toJSON = genericToJSON defaultOptions{fieldLabelModifier=labelModifier 7} 79 | 80 | data AuthenticationResponse = AuthenticationResponse { authenticationResponseAccessToken :: Text 81 | , authenticationResponseClientToken :: Text 82 | , authenticationResponseAvailableProfiles :: [Profile] 83 | , authenticationResponseSelectedProfile :: Profile 84 | } deriving (Generic, Show) 85 | instance FromJSON AuthenticationResponse where 86 | parseJSON = genericParseJSON defaultOptions{fieldLabelModifier=labelModifier 22} 87 | 88 | data JoinRequest = JoinRequest { joinRequestAccessToken :: Text 89 | , joinRequestSelectedProfile :: Text 90 | , joinRequestServerId :: Text 91 | } deriving (Generic, Show) 92 | 93 | instance ToJSON JoinRequest where 94 | toJSON = genericToJSON defaultOptions{fieldLabelModifier=labelModifier 11} 95 | 96 | data RefreshRequest = RefreshRequest { refreshRequestAccessToken :: Text 97 | , refreshRequestClientToken :: Text 98 | , refreshRequestRequestUser :: Bool 99 | } deriving (Generic, Show) 100 | 101 | instance ToJSON RefreshRequest where 102 | toJSON = genericToJSON defaultOptions{fieldLabelModifier=labelModifier 14} 103 | 104 | data RefreshResponse = RefreshResponse { refreshResponseAccessToken :: Text 105 | , refreshResponseClientToken :: Text 106 | , refreshResponseSelectedProfile :: Profile 107 | } deriving (Generic, Show) 108 | 109 | instance FromJSON RefreshResponse where 110 | parseJSON = genericParseJSON defaultOptions{fieldLabelModifier=labelModifier 15} 111 | 112 | makeFields ''Agent 113 | makeFields ''AuthenticationRequest 114 | makeFields ''AuthenticationResponse 115 | makeFields ''Profile 116 | makeFields ''JoinRequest 117 | makeFields ''RefreshRequest 118 | makeFields ''RefreshResponse 119 | 120 | --type API = "authenticate" :> ReqBody '[JSON] AuthenticationRequest 121 | 122 | type SessionAPI = "session" :> "minecraft" :> "join" :> ReqBody '[JSON] JoinRequest :> PostNoContent '[JSON] NoContent 123 | 124 | type AuthAPI = "authenticate" :> ReqBody '[JSON] AuthenticationRequest :> Post '[JSON] AuthenticationResponse 125 | :<|> "refresh" :> ReqBody '[JSON] RefreshRequest :> Post '[JSON] RefreshResponse 126 | 127 | sessionApi :: Proxy SessionAPI 128 | sessionApi = Proxy 129 | 130 | authApi :: Proxy AuthAPI 131 | authApi = Proxy 132 | 133 | 134 | execute :: String -> ClientM a -> IO (Either ServantError a) 135 | execute uri client = do 136 | manager <- newManager tlsManagerSettings 137 | runClientM client $ ClientEnv manager (BaseUrl Https uri 443 "") 138 | 139 | executeAuth :: ClientM a -> IO (Either ServantError a) 140 | executeAuth = execute "authserver.mojang.com" 141 | 142 | executeSession :: ClientM a -> IO (Either ServantError a) 143 | executeSession = execute "sessionserver.mojang.com" 144 | 145 | 146 | joinM :: JoinRequest -> ClientM NoContent 147 | joinM = client sessionApi 148 | 149 | join :: JoinRequest -> IO Bool 150 | join req = isRight <$> executeSession (joinM req) 151 | 152 | authenticateM :: AuthenticationRequest -> ClientM AuthenticationResponse 153 | refreshM :: RefreshRequest -> ClientM RefreshResponse 154 | authenticateM :<|> refreshM = client authApi 155 | 156 | authenticate :: AuthenticationRequest -> IO (Maybe AuthenticationResponse) 157 | authenticate req = executeAuth (authenticateM req) >>= \case 158 | Left err -> print err >> pure Nothing 159 | Right res -> pure $ Just res 160 | 161 | refresh :: RefreshRequest -> IO (Maybe RefreshResponse) 162 | refresh req = executeAuth (refreshM req) >>= \case 163 | Left err -> print err >> pure Nothing 164 | Right res -> pure $ Just res 165 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | extra-package-dbs: [] 3 | packages: 4 | - location: . 5 | extra-deps: 6 | - hjpath-3.0.1 7 | - hjson-1.3.2 8 | - ref-tf-0.4.0.1 9 | - git: https://github.com/reflex-frp/reflex.git 10 | commit: 4a03273794aa4c9a9965e3e6a45fa3c68fa4659a 11 | - git: https://github.com/bennofs/reflex-host.git 12 | commit: ab72c16077ab3bcc1c1e81312aac1090e64b97d4 13 | - prim-uniq-0.1.0.1 14 | resolver: nightly-2017-11-17 15 | --------------------------------------------------------------------------------