src/Gargantext/Prelude/Crypto/Pass/Machine.hs

   1 {-|
   2 Module      : Gargantext.Prelude.Crypto.Pass.Machine
   3 Description :
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : Public Domain
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Random Text generator (for machines mainly)
  11
  12 Thanks to
  13 https://zuttobenkyou.wordpress.com/2011/12/23/simple-password-generation-with-haskell/
  14
  15 -}
  16
  17
  18 module Gargantext.Prelude.Crypto.Pass.Machine
  19       where
  20
  21 import Data.List (nub)
  22 -- import System.Environment (getArgs)
  23 -- import System.IO (hSetEcho)
  24 import Control.Monad.State
  25 import Crypto.Random (cprgGenerate)
  26 import Crypto.Random.AESCtr
  27 import Data.Binary (decode)
  28 import Prelude
  29 import qualified Data.ByteString.Lazy as B
  30 import Data.ByteString as S (ByteString, unpack)
  31 import Data.ByteString.Char8 as C8 (pack)
  32 import Data.Char (chr)
  33
  34 strToBS :: String -> S.ByteString
  35 strToBS = C8.pack
  36
  37 bsToStr :: S.ByteString -> String
  38 bsToStr = map (chr . fromEnum) . S.unpack
  39
  40
  41 keysChar, keysNum, keysPunc, keysCharNum, keysAll, keysHex :: String
  42 keysChar = ['a'..'z'] ++ ['A'..'Z']
  43 keysHex = ['a'..'f']
  44 keysNum = ['0'..'9']
  45 keysPunc = "`~!@#$%^&*()-_=+[{]}\\|;:'\",<.>/? "
  46 keysCharNum = keysChar ++ keysNum
  47 keysAll = keysChar ++ keysNum ++ keysPunc
  48
  49 giveKey ::  String -> Char -> Int -> Char
  50 giveKey keysCustom c n = extractChar $ case c of
  51     'i'  -> (keysNum ++ keysHex)
  52     'j'  -> keysNum
  53     'k'  -> keysChar
  54     'l'  -> keysCharNum
  55     ';'  -> keysPunc
  56     'h'  -> (keysCharNum ++ keysCustom)
  57     '\n' -> ['\n']
  58     _    -> keysAll
  59     where
  60     extractChar xs = xs!!mod n (length xs)
  61
  62 showRandomKey :: Int -> String -> StateT AESRNG IO ()
  63 showRandomKey len keysCustom = handleKey =<< liftIO getChar
  64     where
  65     handleKey key = case key of
  66         '\n' -> liftIO (putChar '\n') >> showRandomKey len keysCustom
  67         'q' -> (liftIO $ putStrLn "\nBye!") >> return ()
  68         _ -> mapM_ f [0..len] >> (liftIO $ putStrLn []) >> showRandomKey len keysCustom
  69         where
  70         f _ = liftIO
  71             . putChar
  72             . giveKey keysCustom key
  73             . (\n -> mod n (length (keysAll ++ keysCustom) - 1))
  74             =<< aesRandomInt
  75
  76
  77 aesRandomInt :: StateT AESRNG IO Int
  78 aesRandomInt = do
  79     aesState <- get
  80     -- aesState <- liftIO makeSystem
  81     -- let aesState = 128
  82     let (bs, aesState') = cprgGenerate 64 aesState
  83     put aesState'
  84     return (decode $ B.fromChunks [bs])
  85
  86 printPass :: Int -> IO ()
  87 printPass len = do
  88   let as = ["alphanumeric","punctuation"]
  89   let as' = filter (\c -> elem c keysAll) . nub $ unwords as
  90   aesState <- makeSystem -- gather entropy from the system to use as the initial seed
  91   _ <- runStateT (showRandomKey len as') aesState -- enter loop
  92   return ()
  93
  94 gargPassMachine :: IO (Int, AESRNG)
  95 gargPassMachine = do
  96   aesState <- makeSystem -- gather entropy from the system to use as the initial seed
  97   pass <- runStateT aesRandomInt aesState -- enter loop
  98   pure pass
  99
 100
 101 {-
 102 main :: IO ()
 103 main = do
 104     hSetBuffering stdin NoBuffering  -- disable buffering from STDIN
 105     hSetBuffering stdout NoBuffering -- disable buffering from STDOUT
 106     hSetEcho stdin False             -- disable terminal echo
 107     as <- getArgs
 108     let as' = filter (\c -> elem c keysAll) . nub $ unwords as
 109     mapM_ putStrLn
 110         [ []
 111         , "poke: 'q'     quit"
 112         , "      'j'     number"
 113         , "      'k'     letter"
 114         , "      'l'     alphanumeric"
 115         , "      ';'     punctuation"
 116         , "      'h'     alphanumeric" ++ (if null as' then [] else " + " ++ as')
 117         , "      'i'     hexadecimal"
 118         , "      'ENTER' newline"
 119         , "      else    any"
 120         , []
 121         ]
 122     aesState <- makeSystem -- gather entropy from the system to use as the initial seed
 123     _ <- runStateT (showRandomKey as') aesState -- enter loop
 124     return ()
 125 -}