src/Gargantext/Prelude/Crypto/Pass.hs

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